commit - /dev/null
commit + 665c255dd18a42b23f14a5dad17cc3139d573d4a
blob - /dev/null
blob + c36ac117f8404a5a2e661117bda79ee3a88dd847 (mode 644)
--- /dev/null
+++ #ex1-17.scm#
+(define (* a b)
+ (if (= b 0)
+ 0
+ (+ a (* a (- b 1)))))
+
+;; a * b = {
+;; 0 if b = 0,
+;; 2 * a * (b/2) if b is even,
+;; a + a * (b-1) if b is odd
+;; }
+
+(define (fast-mult a b)
+ (cond ((= b 0) 0)
+ ((even? b) (double (* a (halve b))))
+ (else (+ a (* a (- b 1))))))
+(define (double x)
+ (+ x x))
+(define (halve x)
+ (/ x 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (fast-mult 0 0) 0)
+(test-case (fast-mult 0 1) 0)
+(test-case (fast-mult 0 8) 0)
+(test-case (fast-mult 5 0) 0)
+(test-case (fast-mult 2 1) 2)
+(test-case (fast-mult 3 3) 9)
+(test-case (fast-mult 5 4) 20)
+(test-case (fast-mult 12 13) 156)
+(test-case (fast-mult 12 24) 288)
+
blob - /dev/null
blob + 9fcd7a9b932ef88eeb5a3e96c1e9708e08588808 (mode 644)
--- /dev/null
+++ #ex1-17.sicp#
+(define (* a b)
blob - /dev/null
blob + 35a7f803e0d3197d31240c0d9d881495b450ee2f (mode 644)
--- /dev/null
+++ #ex1-29.scm#
+(define (sum term a next b)
+ (if (> a b)
+ 0
+ (+ (term a)
+ (sum term (next a) next b))))
+
+;; (define (simpsons-rule f a b n)
+;; (let ((h (/ (- b a) n)))
+;; (define (running-sum k)
+;; (let ((akh (+ a (* k h))))
+;; (if (= k n)
+;; (f akh)
+;; (+ (cond ((= k 0) (f akh))
+;; ((even? k) (* 2 (f akh)))
+;; ((odd? k) (* 4 (f akh))))
+;; (running-sum (+ k 1))))))
+;; (* (/ h 3)
+;; (running-sum 0))))
+
+(define (simpsons-rule f a b n)
+ (let ((h (/ (- b a) n)))
+ (define (simpsons-term k)
+ (let ((akh (+ a (* k h))))
+ (* (f akh)
+ (cond ((or (= k 0) (= k n)) 1)
+ ((odd? k) 4)
+ ((even? k) 2)))))
+ (* (/ h 3)
+ (sum simpsons-term 0 1+ n))))
+
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (cube x) (* x x x))
+
+(test-case (simpsons-rule cube 0.0 1.0 5) 0.25)
+(test-case (simpsons-rule cube 0.0 1.0 10) 0.25)
+(test-case (simpsons-rule cube 0.0 1.0 100) 0.25)
+
blob - /dev/null
blob + e74e9585493f60492d1f046003c349f4f7dd6531 (mode 644)
--- /dev/null
+++ #ex1-46.lisp#
+(defun iterative-improve (good-enough? improve)
+ (lambda (first-guess)
+ (labels ((improve-iter (guess)
+ (let ((improved-guess (funcall improve guess)))
+ (if (funcall good-enough? guess improved-guess)
+ improved-guess
+ (improve-iter improved-guess)))))
+ (improve-iter first-guess))))
+(defun improved-sqrt (num)
+ (funcall (iterative-improve
+ (lambda (x y)
+ (let ((ratio (/ x y)))
+ (and (< ratio 1.001) (> ratio 0.999))))
+ (lambda (guess)
+ (average guess (/ num guess))))
+ 1.0))
+(defvar *tolerance* 0.00001)
+(defun improved-fixed-point (f first-guess)
+ (funcall (iterative-improve
+ (lambda (x y)
+ (< (abs (- x y)) *tolerance*))
+ (lambda (guess)
+ (funcall f guess)))
+ first-guess))
+
blob - /dev/null
blob + 502e2391c7380ce9e44e7cca4ffcddefc1aa06e1 (mode 644)
--- /dev/null
+++ #ex2-1.scm#
+(define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+(define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+(define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+(define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+(define (equal-rat? x y)
+ (= (* (numer x) (denom y))
+ (* (numer y) (denom x))))
+
+(define (print-rat x)
+ (newline)
+ (display (numer x))
+ (display "/")
+ (display (denom x)))
+
+
+(define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+;; (define (make-rat n d)
+;; (let ((g (gcd n d)))
+;; (cons (/ n g) (/ d g))))
+(define (numer x) (car x))
+(define (denom x) (cdr x))
+
+;; (define one-half (make-rat 1 2))
+;; (define one-third (make-rat 1 3))
+
+;; (print-rat one-half)
+;; (print-rat (make-rat 1 2))
+;; (print-rat (add-rat one-third one-third))
+;; (print-rat (make-rat 2 3))
+;; (print-rat (add-rat one-half one-third))
+;; (print-rat (make-rat 5 6))
+;; (print-rat (mul-rat one-half one-third))
+;; (print-rat (make-rat 1 6))
+;; (print-rat (add-rat one-third one-third))
+;; (print-rat (make-rat 2 3))
+
+;; Exercise 2.1. Define a better version of make-rat that handles both positive and negative arguments. Make-rat should normalize the sign so that if the rational number is positive, both the numerator and denominator are positive, and if the rational number is negative, only the numerator is negative.
+
+(define (make-rat n d)
+ (if (= d 0)
+ (error "Division by zero")
+ (let ((g-mag (abs (gcd n d)))
+ (n-mag (abs n))
+ (d-mag (abs d)))
+ (if (< (* n d) 0)
+ (cons (- (/ n-mag g-mag)) (/ d-mag g-mag))
+ (cons (/ n-mag g-mag) (/ d-mag g-mag))))))
+
+;; (define zz-0-0 (make-rat 0 0))
+(define zp-0-3 (make-rat 0 3))
+(define np-1-2 (make-rat -1 2))
+(define np-1-4 (make-rat -1 4))
+(define nn-3-4 (make-rat -3 -4))
+(define pp-4-3 (make-rat 4 3))
+(define pn-5-2 (make-rat 5 -2))
+(define pn-10-2 (make-rat 10 -2))
+(define nn-9-3 (make-rat -9 -3))
+
+;; (print-rat zz-0-0)
+;; (error "Division by zero")
+(print-rat zp-0-3)
+(display "=0/1")
+(print-rat np-1-2)
+(display "=-1/2")
+(print-rat np-1-4)
+(display "=-1/4")
+(print-rat nn-3-4)
+(display "=3/4")
+(print-rat pp-4-3)
+(display "=4/3")
+(print-rat pn-5-2)
+(display "=-5/2")
+(print-rat pn-10-2)
+(display "=-5/1")
+(print-rat nn-9-3)
+(display "=3/1")
+(print-rat (sub-rat nn-9-3 pp-4-3))
+(display "=5/3")
+(print-rat (mul-rat np-1-2 np-1-2))
+(display "=1/4")
+(print-rat (div-rat pn-5-2 pn-10-2))
+(display "=1/2")
+(print-rat (sub-rat np-1-4 zp-0-3))
+(display "=-1/4")
+;; (print-rat (div-rat nn-3-4 zp-0-3))
+;; (error "Division by zero")
+(print-rat (div-rat np-1-4 pn-5-2))
+(display "=1/10")
+
blob - /dev/null
blob + c4ac9e99b701116a764568385c592b4a21c51063 (mode 644)
--- /dev/null
+++ #ex2-14b.scm#
+(define (par1 r1 r2)
+ (div-interval (mul-interval r1 r2)
+ (add-interval r1 r2)))
+(define (par2 r1 r2)
+ (let ((one (make-interval 1 1)))
+ (div-interval one
+ (add-interval (div-interval one r1)
+ (div-interval r2)))))
+
+(define a (make-center-percent 100 5))
+(define b (make-center-percent 200 2))
+(define aa (div-interval a a))
+(define ab (div-interval a b))
+(center aa)
+(center ab)
+(percent aa)
+(percent ab)
+(define apb1 (par1 a b))
+(define apb2 (par2 a b))
+apb1
+apb2
+(define apa1 (par1 a a))
+(define apa2 (par2 a a))
blob - /dev/null
blob + 90e418df64de63eb901dfd47d629433344b97410 (mode 644)
--- /dev/null
+++ #ex2-17.sc#
+(cons 1
+ (cons 2
+ (cons 3
\ No newline at end of file
blob - /dev/null
blob + 2de1ccb6914ef9a38ee91bdd2e89e67c32f2a0f8 (mode 644)
--- /dev/null
+++ #ex2-36.scm#
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+;; Exercise 2.36. The procedure accumulate-n is similar to accumulate except that it takes as its third argument a sequence of sequences, which are all assumed to have the same number of elements. It applies the designated accumulation procedure to combine all the first elements of the sequences, all the second elements of the sequences, and so on, and returns a sequence of the results. For instance, if s is a sequence containing four sequences, ((1 2 3) (4 5 6) (7 8 9) (10 11 12)), then the value of (accumulate-n + 0 s) should be the sequence (22 26 30). Fill in the missing expressions in the following definition of accumulate-n:
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ '()
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+(test-case (accumulate-n + 0 '((1 2 3) (4 5 6) (7 8 9) (10 11 12))) '(22 26 30))
+(test-case (accumulate-n + 0 '(() () ())) '())
+;; (test-case (accumulate-n + 0 '()) (error "Trying to car empty list"))
+
blob - /dev/null
blob + d45237872ca6fbd8a7cf9a56829195933b583f80 (mode 644)
--- /dev/null
+++ #ex2-56-sol.scm#
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp)
+ (if (same-variable? exp var) 1 0))
+ ((sum? exp)
+ (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp)
+ (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (else
+ (error "unknown expression type -- DERIV" exp))))
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+(define (exponentiation? x)
+ (and (pair? x) (eq? (car x) '**)))
+(define (base e) (cadr e))
+(define (exponent e) (caddr e))
+(define (make-exponentiation base exponent)
+ (cond ((=number? exponent 0) 1)
+ ((=number? exponent 1) base)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ (else (list '** base exponent))))
+((exponentiation? exp)
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation
+ (base exp)
+ (make-sum (exponent exp) -1)))
+ (deriv (base exp) var)))
blob - /dev/null
blob + 5d5d106b0d0fb8e1e035e024b5a3168b5df0189c (mode 644)
--- /dev/null
+++ #ex2-78-sol.scm#
+(define (attach-tag type-tag contents)
+ (if (= type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ (else (error "Bad tagged datum -- TYPE-TAG" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ (else (error "Bad tagged datum -- CONTENTS" datum))))
\ No newline at end of file
blob - /dev/null
blob + e6938f0ed468c274c19fd1c6e74733b354edbfdc (mode 644)
--- /dev/null
+++ #ex2-81-sol.scm#
+(define (attach-tag type-tag contents)
+ (if (number? contents)
+ contents
+ (cons type-tag contents)))
+
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "No method for these types -- APPLY-GENERIC"
+ (list op type-tags))))))
+
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args)))
+ (let ((t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond (t1->t2
+ (apply-generic op (t1->t2 a1) a2))
+ (t2->t1
+ (apply-generic op a1 (t2->t1 a2)))
+ (else
+ (error "No method for these types"
+ (list op type-tags))))))
+ (error "No method for these types"
+ (list op type-tags)))))))
+
+
+
blob - /dev/null
blob + 34a9e4e330a44bcefaceab42cae41dc6c8dbcf3c (mode 644)
--- /dev/null
+++ #ex3-25-4.scm#
+(define (make-table)
+ (let ((local-table (list '*table*)))
+ (define (locate key otherkeys table)
+ (let ((value (assoc key (cdr table))))
\ No newline at end of file
blob - /dev/null
blob + fe6d780fa2491ae56448023a25886dbeb0b4eca7 (mode 644)
--- /dev/null
+++ ex1-1.scm
+10
+10
+(+ 5 3 4)
+12
+(- 9 1)
+8
+(/ 6 2)
+3
+(+ (* 2 4) (- 4 6))
+(+ 8 -2)
+6
+(define a 3)
+a
+(define b (+ a 1))
+b
+(+ a b (* a b))
+(+ 3 4 (* 3 4))
+(+ 3 4 12)
+19
+(= a b)
+#f
+(if (and (> b a) (< b (* a b)))
+ b
+ a)
+(if (and (> 4 3) (< 4 (* 3 4)))
+ 4
+ 3)
+(if (and #t #t)
+ 4
+ 3)
+4
+
+(cond ((= a 4) 6)
+ ((= b 4) (+ 6 7 a))
+ (else 25))
+(cond (#f 6)
+ (#t (+ 6 7 3))
+ (else 25))
+16
+(+ 2 (if (> b a) b a))
+(+ 2 (if #t 4 3))
+(+ 2 4)
+6
+(* (cond ((> a b) a)
+ ((< a b) b)
+ (else -1))
+ (+ a 1))
+(* (cond (#f 3)
+ (#t 4)
+ (else -1))
+ (+ 3 1))
+(* 4
+ 4)
+16
+
blob - /dev/null
blob + 900a330458f925f33ac886b5d9099de6145acdb6 (mode 644)
--- /dev/null
+++ ex1-1.scm~
+10
+(+ 5 3 4)
\ No newline at end of file
blob - /dev/null
blob + 0c8ec49ca773a0b7b9b2618b649f266fddeffc3a (mode 644)
--- /dev/null
+++ ex1-10.scm
+(define (A x y)
+ (cond ((= y 0) 0)
+ ((= x 0) (* 2 y))
+ ((= y 1) 2)
+ (else (A (- x 1)
+ (A x (- y 1))))))
+(A 1 10)
+(A 0 (A 1 9))
+(A 0 (A 0 (A 1 8)))
+(A 0 (A 0 (A 0 (A 1 7))))
+(A 0 (A 0 (A 0 (A 0 (A 1 6)))))
+(A 0 (A 0 (A 0 (A 0 (A 0 (A 1 5))))))
+(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 1 4)))))))
+(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 1 3))))))))
+(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 1 2)))))))))
+(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 1 1))))))))))
+(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 2)))))))))
+(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 4))))))))
+(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 (A 0 8)))))))
+(A 0 (A 0 (A 0 (A 0 (A 0 (A 0 16))))))
+(A 0 (A 0 (A 0 (A 0 (A 0 32)))))
+(A 0 (A 0 (A 0 (A 0 64))))
+(A 0 (A 0 (A 0 128)))
+(A 0 (A 0 256))
+(A 0 512)
+1024
+;; 2^10
+
+(A 2 4)
+(A 1 (A 2 3))
+(A 1 (A 1 (A 2 2)))
+(A 1 (A 1 (A 1 (A 2 1))))
+(A 1 (A 1 (A 1 2)))
+(A 1 (A 1 (A 0 (A 1 1))))
+(A 1 (A 1 (A 0 2)))
+(A 1 (A 1 4))
+(A 1 (A 0 (A 1 3)))
+(A 1 (A 0 (A 0 (A 1 2))))
+...
+(A 1 (A 0 (A 0 (A 0 2))))
+(A 1 (A 0 (A 0 4)))
+(A 1 (A 0 8))
+(A 1 16)
+;; 65536
+;; 2^(2^(2^2)) = 2^16
+
+(A 3 3)
+(A 2 (A 3 2))
+(A 2 (A 2 (A 3 1)))
+(A 2 (A 2 2))
+(A 2 4)
+65536
+;; same as above = 2^16
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define (f n) (A 0 n))
+(define (f n) (* 2 n))
+
+(define (g n) (A 1 n))
+(define (g n)
+ (expt 2 n))
+
+(define (h n) (A 2 n))
+(define (h n)
+ (cond ((= n 0) 0)
+ ((= n 1) 2)
+ (else (expt 2 (h (- n 1))))))
+
+;; 2^(2^(2^(...))) 'n' number of times
+
+
+(define (k n) (* 5 n n))
\ No newline at end of file
blob - /dev/null
blob + 87c2ee8bdda49bed066a47d222423d3084680d3a (mode 644)
--- /dev/null
+++ ex1-10.scm~
+(define (A x y)
+ (cond ((= y 0) 0)
+ ((= x 0) (* 2 y))
+ ((= y 1) 2)
+ (else (A (- x 1)
+ (A x (- y 1))))))
\ No newline at end of file
blob - /dev/null
blob + ea206cf94126c5c1efacd0d1e682afbce8895540 (mode 644)
--- /dev/null
+++ ex1-10b.scm
+(define (fib n)
+ (cond ((= n 0) 0)
+ ((= n 1) 1)
+ (else (+ (fib (- n 1))
+ (fib (- n 2))))))
+
+(define (fib n)
+ (fib-iter 1 0 n))
+(define (fib-iter a b count)
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))
+
+(define (count-change cents coins)
+ (cond ((= coins 0) 0)
+ ((< cents 0) 0)
+ ((= cents 0) 1)
+ (else (+ (count-change cents (- coins 1))
+ (count-change (- cents (largest-coin-value coins)) coins)))))
+
+(define (largest-coin-value coins)
+ (cond ((= coins 5) 50)
+ ((= coins 4) 25)
+ ((= coins 3) 10)
+ ((= coins 2) 5)
+ ((= coins 1) 1)))
+
+(count-change 0 0)
+;; 0
+(count-change 1 0)
+;; 0
+(count-change 0 1)
+;; 1
+(count-change 1 1)
+;; 1
+(count-change 2 1)
+;; 1
+(count-change 2 2)
+;; 1
+(count-change 100 5)
+
+(define (count-change amount)
+ (cc amount 5))
+(define (cc amount kinds-of-coins)
+ (cond ((= amount 0) 1)
+ ((or (< amount 0) (= kinds-of-coins 0)) 0)
+ (else (+ (cc amount
+ (- kinds-of-coins 1))
+ (cc (- amount
+ (first-denomination kinds-of-coins))
+ kinds-of-coins)))))
+(define (first-denomination kinds-of-coins)
+ (cond ((= kinds-of-coins 1) 1)
+ ((= kinds-of-coins 2) 5)
+ ((= kinds-of-coins 3) 10)
+ ((= kinds-of-coins 4) 25)
+ ((= kinds-of-coins 5) 50)))
blob - /dev/null
blob + 29c7bab778d1b78866735cd005afd2376c6b000b (mode 644)
--- /dev/null
+++ ex1-11.lisp
+(defun Fr (n)
+ (cond ((< n 3) n)
+ (t (+ Fr (- n 1))
+ (* 2 (Fr (- n 2)))
+ (* 3 (Fr (- n 3))))))
+(defun F-iter (n)
+ (if (< n 3)
+ n
+ (F-iter-aux 2 1 0 n)))
+(defun F-iter-aux (a b c count)
+ (if (= count 2)
+ a
+ (F-iter-aux (+ a (* 2 b) (* 3 c))
+ a
+ b
+ (- count 1))))
\ No newline at end of file
blob - /dev/null
blob + 97a6c6e72253d28ff7aeb47ef0b54cd1e6cc3f5b (mode 644)
--- /dev/null
+++ ex1-11.lisp~
+(defun Fr (n)
+ (cond ((< n 3) n)
+ (t (+ Fr (- n 1))
+ (* 2 (Fr (- n 2)))
+ (* 3 (Fr (- n 3))))))
\ No newline at end of file
blob - /dev/null
blob + 552c435d8805e6894839f9eaf4f27e1819de228b (mode 644)
--- /dev/null
+++ ex1-11.scm
+(define (f n)
+ (if (< n 3)
+ n
+ (+ (f (- n 1))
+ (* 2 (f (- n 2)))
+ (* 3 (f (- n 3))))))
+
+(load-option 'format)
+;; (load-option 'unquote)
+;; (define (test-case t1 t2)
+;; (format #t "~A: ~A Expected: ~A" `t1, t1, t2))
+(define (test-case actual expected)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (f 0) 0)
+(test-case (f 1) 1)
+(test-case (f 2) 2)
+(test-case (f 3) 4)
+(test-case (f 4) 11)
+
+(define (f2 n)
+ (f-iter 2 1 0 n))
+
+(define (f-iter n1 n2 n3 i)
+ (if (= i 0)
+ n3
+ (f-iter (+ n1 (* 2 n2) (* 3 n3))
+ n1
+ n2
+ (- i 1))))
+
+
+(test-case (f2 0) 0)
+(test-case (f2 1) 1)
+(test-case (f2 2) 2)
+(test-case (f2 3) 4)
+(test-case (f2 4) 11)
blob - /dev/null
blob + ea206cf94126c5c1efacd0d1e682afbce8895540 (mode 644)
--- /dev/null
+++ ex1-11.scm~
+(define (fib n)
+ (cond ((= n 0) 0)
+ ((= n 1) 1)
+ (else (+ (fib (- n 1))
+ (fib (- n 2))))))
+
+(define (fib n)
+ (fib-iter 1 0 n))
+(define (fib-iter a b count)
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))
+
+(define (count-change cents coins)
+ (cond ((= coins 0) 0)
+ ((< cents 0) 0)
+ ((= cents 0) 1)
+ (else (+ (count-change cents (- coins 1))
+ (count-change (- cents (largest-coin-value coins)) coins)))))
+
+(define (largest-coin-value coins)
+ (cond ((= coins 5) 50)
+ ((= coins 4) 25)
+ ((= coins 3) 10)
+ ((= coins 2) 5)
+ ((= coins 1) 1)))
+
+(count-change 0 0)
+;; 0
+(count-change 1 0)
+;; 0
+(count-change 0 1)
+;; 1
+(count-change 1 1)
+;; 1
+(count-change 2 1)
+;; 1
+(count-change 2 2)
+;; 1
+(count-change 100 5)
+
+(define (count-change amount)
+ (cc amount 5))
+(define (cc amount kinds-of-coins)
+ (cond ((= amount 0) 1)
+ ((or (< amount 0) (= kinds-of-coins 0)) 0)
+ (else (+ (cc amount
+ (- kinds-of-coins 1))
+ (cc (- amount
+ (first-denomination kinds-of-coins))
+ kinds-of-coins)))))
+(define (first-denomination kinds-of-coins)
+ (cond ((= kinds-of-coins 1) 1)
+ ((= kinds-of-coins 2) 5)
+ ((= kinds-of-coins 3) 10)
+ ((= kinds-of-coins 4) 25)
+ ((= kinds-of-coins 5) 50)))
blob - /dev/null
blob + 9746c48fa09164960e80402e0c3d2ec9303e5d5d (mode 644)
--- /dev/null
+++ ex1-12.lisp
+(defun pascal (row col)
+ (cond ((= col 1) 1)
+ ((= row col) 1)
+ (t (+ (pascal (1- row) col)
+ (pascal (1- row) (1- col))))))
\ No newline at end of file
blob - /dev/null
blob + 2cc1e7171d93964087e6b5e90bdc838804de43e9 (mode 644)
--- /dev/null
+++ ex1-12.scm
+(define (pascal-rec row col)
+ (cond ((= row col) 1)
+ ((= col 1) 1)
+ (else (+ (pascal-rec (- row 1) (- col 1))
+ (pascal-rec (- row 1) col)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (pascal-rec 1 1) 1)
+(test-case (pascal-rec 2 1) 1)
+(test-case (pascal-rec 2 2) 1)
+(test-case (pascal-rec 3 1) 1)
+(test-case (pascal-rec 3 2) 2)
+(test-case (pascal-rec 3 3) 1)
+(test-case (pascal-rec 4 1) 1)
+(test-case (pascal-rec 4 2) 3)
+(test-case (pascal-rec 4 3) 3)
+(test-case (pascal-rec 4 4) 1)
+(test-case (pascal-rec 5 1) 1)
+(test-case (pascal-rec 5 2) 4)
+(test-case (pascal-rec 5 3) 6)
+(test-case (pascal-rec 5 4) 4)
+(test-case (pascal-rec 5 5) 1)
blob - /dev/null
blob + 2cc1e7171d93964087e6b5e90bdc838804de43e9 (mode 644)
--- /dev/null
+++ ex1-12.scm~
+(define (pascal-rec row col)
+ (cond ((= row col) 1)
+ ((= col 1) 1)
+ (else (+ (pascal-rec (- row 1) (- col 1))
+ (pascal-rec (- row 1) col)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (pascal-rec 1 1) 1)
+(test-case (pascal-rec 2 1) 1)
+(test-case (pascal-rec 2 2) 1)
+(test-case (pascal-rec 3 1) 1)
+(test-case (pascal-rec 3 2) 2)
+(test-case (pascal-rec 3 3) 1)
+(test-case (pascal-rec 4 1) 1)
+(test-case (pascal-rec 4 2) 3)
+(test-case (pascal-rec 4 3) 3)
+(test-case (pascal-rec 4 4) 1)
+(test-case (pascal-rec 5 1) 1)
+(test-case (pascal-rec 5 2) 4)
+(test-case (pascal-rec 5 3) 6)
+(test-case (pascal-rec 5 4) 4)
+(test-case (pascal-rec 5 5) 1)
blob - /dev/null
blob + a35863a2ff33daf475ad38eea519e93b08592d9f (mode 644)
--- /dev/null
+++ ex1-14.scm
+order of growth of the space is equal to the depth (roughly proportional to amount)
+order of growth of steps is equal to number of nodes (roughly 2^amount) ;; this is wrong, actually of order amount^kinds-of-coins but proof is ridiculously complicated
\ No newline at end of file
blob - /dev/null
blob + 6e9ebf5b1de9f885977ffcfdcab97cb7ba1ecbfc (mode 644)
--- /dev/null
+++ ex1-15.scm
+(define (cube x) (* x x x))
+(define (p x) (- (* 3 x) (* 4 (cube x))))
+(define (sine angle)
+ (if (not (> (abs angle) 0.1))
+ angle
+ (p (sine (/ angle 3.0)))))
+
+(sine 12.15)
+(p (sine 4.05))
+(p (p (sine 1.35)))
+(p (p (p (sine 0.45))))
+(p (p (p (p (sine 0.15)))))
+(p (p (p (p (p (sine 0.05))))))
+
+5 times
+
+number of steps is order of log(angle)
+growth of space is order of log(angle) as well
\ No newline at end of file
blob - /dev/null
blob + eabe2016a306941e32762cb0448ce8ff8a7d8630 (mode 644)
--- /dev/null
+++ ex1-15.scm~
+(define (cube x) (* x x x))
+(define (p x) (- (* 3 x) (* 4 (cube x))))
+(define (sine angle)
+ (if (not (> (abs angle) 0.1))
+ angle
+ (p (sine (/ angle 3.0)))))
\ No newline at end of file
blob - /dev/null
blob + b34aef73bbde6d83c92fd8e03fc83e6a54090e11 (mode 644)
--- /dev/null
+++ ex1-16.lisp
+(defun fast-expt-iter (b n &optional (a 1))
+ (cond ((= n 0) a)
+ ((evenp n) (fast-expt-iter (square b) (/ n 2) a))
+ (t (fast-expt-iter b (- n 1) (* b a)))))
\ No newline at end of file
blob - /dev/null
blob + 2b563916e7723fe4d55a635d959b69f95d5d437e (mode 644)
--- /dev/null
+++ ex1-16.scm
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+(define (expt b n)
+ (expt-iter b n 1))
+(define (expt-iter b counter product)
+ (if (= counter 0)
+ product
+ (expt-iter b
+ (- counter 1)
+ (* b product))))
+(define (fast-expt b n)
+ (cond ((= n 0) 1)
+ ((even? n) (square (fast-expt b (/ n 2))))
+ (else (* b (fast-expt b (- n 1))))))
+(define (even? n)
+ (= (remainder n 2) 0))
+
+;; Exercise 1.16. Design a procedure that evolves an iterative exponentiation process that uses successive squaring and uses a logarithmic number of steps, as does fast-expt. (Hint: Using the observation that (b^(n/2))^2 = (b^2)^(n/2), keep, along with the exponent n and the base b, an additional state variable a, and define the state transformation in such a way that the product a*b^n is unchanged from state to state. At the beginning of the process a is taken to be 1, and the answer is given by the value of a at the end of the process. In general, the technique of defining an invariant quantity that remains unchanged from state to state is a powerful way to think about the design of iterative algorithms.)
+
+(define (fast-expt-iter a b n)
+ (cond ((= n 0) a)
+ ((odd? n) (fast-expt-iter (* b a) b (- n 1)))
+ ((even? n) (fast-expt-iter a (square b) (/ n 2)))))
+
+(define (square x) (* x x))
+(define (even? x) (= (remainder x 2) 0))
+(define (odd? x) (= (remainder x 2) 1))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (fast-expt-iter 2 1 0) 2)
+(test-case (fast-expt-iter 2 0 5) 0)
+(test-case (fast-expt-iter 0 4 0) 0)
+(test-case (fast-expt-iter 0 0 4) 0)
+(test-case (fast-expt-iter 3 2 0) 3)
+(test-case (fast-expt-iter 5 2 4) 80)
+(test-case (fast-expt-iter 10 3 6) 7290)
+(test-case (fast-expt-iter 8 4 3) 512)
+
+;; these test cases wouldn't work
+;; (fast-expt-iter 2 0 0)
+;; (fast-expt-iter 0 0 0)
blob - /dev/null
blob + 1cf0407df2e42c00c451168554571899bbe9723b (mode 644)
--- /dev/null
+++ ex1-16.scm~
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+(define (expt b n)
+ (expt-iter b n 1))
+(define (expt-iter b counter product)
+ (if (= counter 0)
+ product
+ (expt-iter b
+ (- counter 1)
+ (* b product))))
+(define (fast-expt b n)
+ (cond ((= n 0) 1)
+ ((even? n) (square (fast-expt b (/ n 2))))
+ (else (* b (fast-expt b (- n 1))))))
+(define (even? n)
+ (= (remainder n 2) 0))
+
+;; Exercise 1.16. Design a procedure that evolves an iterative exponentiation process that uses successive squaring and uses a logarithmic number of steps, as does fast-expt. (Hint: Using the observation that (b^(n/2))^2 = (b^2)^(n/2), keep, along with the exponent n and the base b, an additional state variable a, and define the state transformation in such a way that the product a*b^n is unchanged from state to state. At the beginning of the process a is taken to be 1, and the answer is given by the value of a at the end of the process. In general, the technique of defining an invariant quantity that remains unchanged from state to state is a powerful way to think about the design of iterative algorithms.)
+
+(define (fast-expt-iter a b n)
+ (cond ((= n 0) a)
+ ((odd? n) (fast-expt-iter (* b a) b (- n 1)))
+ ((even? n) (fast-expt-iter a (square b) (/ n 2)))))
+
+(define (square x) (* x x))
+(define (even? x) (= (remainder x 2) 0))
+(define (odd? x) (= (remainder x 2) 1))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (fast-expt-iter 2 1 0) 2)
+(test-case (fast-expt-iter 2 0 5) 0)
+(test-case (fast-expt-iter 0 4 0) 0)
+(test-case (fast-expt-iter 0 0 4) 0)
+(test-case (fast-expt-iter 3 2 0) 3)
+(test-case (fast-expt-iter 5 2 4) 80)
+(test-case (fast-expt-iter 10 3 6) 7290)
+(test-case (fast-expt-iter 8 4 3) 512)
+
+;; these test cases wouldn't work
+;; (fast-expt-iter 2 0 0)
+;; (fast-expt-iter 0 0 0)
blob - /dev/null
blob + 0221c8b4fdd419f2da677634cbdc3f76883bfb15 (mode 644)
--- /dev/null
+++ ex1-17.lisp
+(defun double (x)
+ (* x 2))
+(defun halve (x)
+ (/ x 2))
+(defun fast-mult (a b)
+ (cond ((= b 0) 0)
+ ((= b 1) a)
+ ((evenp b) (double (fast-mult a (halve b))))
+ (t (+ a (fast-mult a (- b 1))))))
\ No newline at end of file
blob - /dev/null
blob + 2af32dda802d2479ab3abfb316bb03eaf3e20bd6 (mode 644)
--- /dev/null
+++ ex1-17.lisp~
+(defun double (x)
+ (* x 2))
+(defun halve (x)
+ (/ x 2))
+(defun fast-mult (a b)
+ (cond ((= b 0) 0)
+ ((= b 1) a)
+ ((evenp b) (double (fast-mult a (halve b))))
+
\ No newline at end of file
blob - /dev/null
blob + c36ac117f8404a5a2e661117bda79ee3a88dd847 (mode 644)
--- /dev/null
+++ ex1-17.scm
+(define (* a b)
+ (if (= b 0)
+ 0
+ (+ a (* a (- b 1)))))
+
+;; a * b = {
+;; 0 if b = 0,
+;; 2 * a * (b/2) if b is even,
+;; a + a * (b-1) if b is odd
+;; }
+
+(define (fast-mult a b)
+ (cond ((= b 0) 0)
+ ((even? b) (double (* a (halve b))))
+ (else (+ a (* a (- b 1))))))
+(define (double x)
+ (+ x x))
+(define (halve x)
+ (/ x 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (fast-mult 0 0) 0)
+(test-case (fast-mult 0 1) 0)
+(test-case (fast-mult 0 8) 0)
+(test-case (fast-mult 5 0) 0)
+(test-case (fast-mult 2 1) 2)
+(test-case (fast-mult 3 3) 9)
+(test-case (fast-mult 5 4) 20)
+(test-case (fast-mult 12 13) 156)
+(test-case (fast-mult 12 24) 288)
+
blob - /dev/null
blob + ae05641b0ba60bfedac4805ac94ea027c0333169 (mode 644)
--- /dev/null
+++ ex1-17.scm~
+(define (* a b)
+ (if (= b 0)
+ 0
+ (+ a (* a (- b 1)))))
+
+;; a * b = {
+;; 0 if b = 0,
+;; 2 * a * (b/2) if b is even,
+;; a + a * (b-1) if b is odd
+;; }
+
+(define (fast-mult a b)
+ (cond ((= b 0) 0)
+ ((even? b) (double (* a (halve b))))
+ (else (+ a (* a (- b 1))))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (fast-expt-iter 2 1 0) 2)
blob - /dev/null
blob + 6d66ff64da8921787acfa97a43995c2addf56ecc (mode 644)
--- /dev/null
+++ ex1-18.lisp
+(defun fast-mult-iter (a b &optional (acc 0))
+ (cond ((= b 0) acc)
+ ((evenp b) (fast-mult-iter (double a) (halve b) acc))
+ (t (fast-mult-iter a (1- b) (+ a acc)))))
\ No newline at end of file
blob - /dev/null
blob + 09c21c88cf3bbfb1cc4024e2c24fe72572a4c785 (mode 644)
--- /dev/null
+++ ex1-18.scm
+;; Exercise 1.18. Using the results of exercises 1.16 and 1.17, devise a procedure that generates an iterative process for multiplying two integers in terms of adding, doubling, and halving and uses a logarithmic number of steps.40
+
+;; invariant quantity
+;; t + a * b = {
+;; t if b = 0
+;; t + 2 * a * (b/2) if b even
+;; (t+a) + a * (b-1) if b odd
+;; }
+
+(define (fast-mult-iter a b t)
+ (cond ((= b 0) t)
+ ((even? b) (double fast-mult-iter a (halve b) t))
+ (else (fast-mult-iter a (- b 1) (+ t a)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+(test-case (fast-mult 0 0) 0)
+(test-case (fast-mult 0 1) 0)
+(test-case (fast-mult 0 8) 0)
+(test-case (fast-mult 5 0) 0)
+(test-case (fast-mult 2 1) 2)
+(test-case (fast-mult 3 3) 9)
+(test-case (fast-mult 5 4) 20)
+(test-case (fast-mult 12 13) 156)
+(test-case (fast-mult 12 24) 288)
+
+
+
blob - /dev/null
blob + 418a8b61185c480e7e3f78d2c0be186c63df6bfe (mode 644)
--- /dev/null
+++ ex1-18.scm~
+ Exercise 1.18. Using the results of exercises 1.16 and 1.17, devise a procedure that generates an iterative process for multiplying two integers in terms of adding, doubling, and halving and uses a logarithmic number of steps.40
\ No newline at end of file
blob - /dev/null
blob + dad887572d646910d4c292dda9306d5f412a9052 (mode 644)
--- /dev/null
+++ ex1-19.scm
+(define (square x)
+ (* x x))
+(define (fib n)
+ (fib-iter 1 0 0 1 n))
+(define (fib-iter a b p q count)
+ (cond ((= count 0) b)
+ ((even? count) (fib-iter a
+ b
+ (+ (square q) (square p))
+ (+ (* 2 q p) (square q))
+ (/ count 2)))
+ (else (fib-iter (+ (* b q) (* a q) (* a p))
+ (+ (* b p) (* a q))
+ p
+ q
+ (- count 1)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (fib 0) 0)
+(test-case (fib 1) 1)
+(test-case (fib 2) 1)
+(test-case (fib 3) 2)
+(test-case (fib 4) 3)
+(test-case (fib 5) 5)
+(test-case (fib 6) 8)
+(test-case (fib 7) 13)
+(test-case (fib 8) 21)
+(test-case (fib 9) 34)
+
+(define (fib n)
+ (fib-iter 1 0 0 1 n)
+
+(define (fib-iter a b p q n)
+ (cond ((= n 0) b)
+ ((even? n) (fib-iter a
+ b
+ (+ (square p) (square q))
+ (+ (* 2 p q) (square q))
+ (/ n 2)))
+ (else (fib-iter (+ (* b q) (* a q) (* a p))
+ (+ (* b p) (* a q))
+ p
+ q
+ (- n 1)))))
\ No newline at end of file
blob - /dev/null
blob + 2f9e5ce1a8a19afa3d8a6a60ef0b3fa8862991d3 (mode 644)
--- /dev/null
+++ ex1-19.scm~
+(define (fib n)
+ (fib-iter 1 0 0 1 n))
+(define (fib-iter a b p q count)
+ (cond ((= count 0) b)
+ ((even? count) (fib-iter a
+ b
+ (+ (* 2 q p) (square q))
+ (+ (square q) (square p))
+ (/ count 2)))
+ (else (fib-iter (+ (
\ No newline at end of file
blob - /dev/null
blob + 91b598086dfc39895d2d22ff933822f842ea1dfb (mode 644)
--- /dev/null
+++ ex1-2.scm
+(/ (+ 5 4 (- 2
+ (- 3
+ (+ 6
+ (/ 4 5)))))
+ (* 3 (- 6 2) (- 2 7)))
\ No newline at end of file
blob - /dev/null
blob + da3a38e1f0e0f13ba10083982040344d6fcb8c94 (mode 644)
--- /dev/null
+++ ex1-2.scm~
+(/ (+ 5 4 (- 2
+ (- 3
+ (+ 6
+ (/ 4 3)))))
+ (* 3 (- 6 2) (- 2 7)))
\ No newline at end of file
blob - /dev/null
blob + 5db7c285c754f1ec524c50aac3f1b9359174cf2a (mode 644)
--- /dev/null
+++ ex1-20.scm
+(define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+
+(gcd 206 40)
+(gcd 40 (remainder 206 40))
+evaluate remainder once
+(gcd (remainder 206 40) (remainder 40 (remainder 206 40)))
+evaluate remainder three times
+(gcd (remainder 40 (remainder 206 40)) (remainder (remainder 206 40) (remainder 40 (remainder 206 40))))
+evaluate remainder 7 times
+(gcd (remainder (remainder 206 40) (remainder 40 (remainder 206 40))) (remainder (remainder 40 (remainder 206 40)) (remainder (remainder 206 40) (remainder 40 (remainder 206 40)))))
+evaluate remainder 14 times
+(remainder (remainder 206 40) (remainder 40 (remainder 206 40)))
+(remainder 6 (remainder 40 (remainder 206 40)))
+(remainder 6 (remainder 40 (remainder 206 40))) ;; 15 times
+(remainder 6 (remainder 40 6)) ;; 16 times
+(remainder 6 4) ;; 17 times
+2 ;; 18 times
+
+18 remainder operations are performed in normal order, whereas only 4 are performed in normal-order
\ No newline at end of file
blob - /dev/null
blob + b9af13619479b3a56d270bf02b844d67fd47ea7b (mode 644)
--- /dev/null
+++ ex1-20.scm~
+(define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
\ No newline at end of file
blob - /dev/null
blob + 64b5f92f5683f247d6f703673a467ea24e9057b9 (mode 644)
--- /dev/null
+++ ex1-21.scm
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (fermat-test n)
+ (define (try-it a)
+ (= (expmod a n n) a))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (fast-prime? n times)
+ (cond ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+(define (smallest-divisor n)
+ (find-divisor n 2))
+(define (find-divisor n test-divisor)
+ (cond ((> (square test-divisor) n) n)
+ ((divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (smallest-divisor 199) 199)
+(test-case (smallest-divisor 1999) 1999)
+(test-case (smallest-divisor 19999) 7)
+
+
+
blob - /dev/null
blob + a524b98eb61ae95bff8056efbe319546ffbcedf2 (mode 644)
--- /dev/null
+++ ex1-21.scm~
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (fermat-test n)
+ (define (try-it a)
+ (= (expmod a n n) a))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (fast-prime? n times)
+ (cond ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+(define (smallest-divisor n)
+ (find-divisor n 2))
+(define (find-divisor n test-divisor)
+ ((> (- (square test-divisor) n)) n)
+ ((divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+
+;;(display (smallest-divisor 199))
+;;(display (smallest-divisor 1999))
+;;(display (smallest-divisor 19999))
+;;(smallest-divisor 19999)
\ No newline at end of file
blob - /dev/null
blob + fd243208d841417be40fc87c0e8bb8309fef6f52 (mode 644)
--- /dev/null
+++ ex1-22.lisp
+(defun search-for-primes (start end)
+ (let ((start (if (evenp start) (1+ start) start)))
+ (do ((i start (+ i 2)))
+ ((> i end))
+ (when (prime? i)
+ (format t "~d is prime~%" i)))))
+
+(time (dotimes (i 1000 t) (search-for-primes 1000 1019)))
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 95406b1308abe9cbc0c4751b2c87fc70b6c6377c (mode 644)
Binary files /dev/null and ex1-22.ods differ
blob - /dev/null
blob + 4b3832d5ffc43f111baff4d71e0abe7cee041e19 (mode 644)
--- /dev/null
+++ ex1-22.scm
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (fermat-test n)
+ (define (try-it a)
+ (= (expmod a n n) a))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (fast-prime? n times)
+ (cond ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+(define (smallest-divisor n)
+ (find-divisor n 2))
+(define (find-divisor n test-divisor)
+ (cond ((> (square test-divisor) n) n)
+ ((divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+(define (prime? n)
+ (= n (smallest-divisor n)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+(search-for-primes 100000001 100000099)
+(search-for-primes 1000000001 1000000099)
+(search-for-primes 10000000001 10000000099)
+(search-for-primes 100000000001 100000000099)
+(search-for-primes 1000000000001 1000000000099)
+(search-for-primes 10000000000001 10000000000099)
+(search-for-primes 100000000000001 100000000000099)
+
+;; see spreadsheet for results and charts
+
+;; Yes, our timing data perfectly fits the order of growth prediction that R(n) is of the order sqrt(n). So, it seems that our programs do run in time proportional to number of steps required.
+
blob - /dev/null
blob + 64b5f92f5683f247d6f703673a467ea24e9057b9 (mode 644)
--- /dev/null
+++ ex1-22.scm~
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (fermat-test n)
+ (define (try-it a)
+ (= (expmod a n n) a))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (fast-prime? n times)
+ (cond ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+(define (smallest-divisor n)
+ (find-divisor n 2))
+(define (find-divisor n test-divisor)
+ (cond ((> (square test-divisor) n) n)
+ ((divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (smallest-divisor 199) 199)
+(test-case (smallest-divisor 1999) 1999)
+(test-case (smallest-divisor 19999) 7)
+
+
+
blob - /dev/null
blob + ea86bb08e494691ff41bdbf7c72db2d8b59ab6fb (mode 644)
Binary files /dev/null and ex1-23.ods differ
blob - /dev/null
blob + 2e2aef81cb909503f4ed9ba2d5a91f2cdce35e14 (mode 644)
--- /dev/null
+++ ex1-23.scm
+;; (define (expmod base exp m)
+;; (cond ((= exp 0) 1)
+;; ((even? exp)
+;; (remainder (square (expmod base (/ exp 2) m)) m))
+;; (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+;; (define (fermat-test n)
+;; (define (try-it a)
+;; (= (expmod a n n) a))
+;; (try-it (+ 1 (random (- n 1)))))
+
+;; (define (fast-prime? n times)
+;; (cond ((= times 0) true)
+;; ((fermat-test n) (fast-prime? n (- times 1)))
+;; (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+;; Exercise 1.23. The smallest-divisor procedure shown at the start of this section does lots of needless testing: After it checks to see if the number is divisible by 2 there is no point in checking to see if it is divisible by any larger even numbers. This suggests that the values used for test-divisor should not be 2, 3, 4, 5, 6, ..., but rather 2, 3, 5, 7, 9, .... To implement this change, define a procedure next that returns 3 if its input is equal to 2 and otherwise returns its input plus 2. Modify the smallest-divisor procedure to use (next test-divisor) instead of (+ test-divisor 1). With timed-prime-test incorporating this modified version of smallest-divisor, run the test for each of the 12 primes found in exercise 1.22. Since this modification halves the number of test steps, you should expect it to run about twice as fast. Is this expectation confirmed? If not, what is the observed ratio of the speeds of the two algorithms, and how do you explain the fact that it is different from 2?
+
+(define (smallest-divisor n)
+ (find-divisor n 2))
+(define (find-divisor n test-divisor)
+ (define (next-divisor n)
+ (if (= n 2)
+ 3
+ (+ n 2)))
+ (cond ((> (square test-divisor) n) n)
+ ((divides? test-divisor n) test-divisor)
+ (else (find-divisor n (next-divisor test-divisor)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+(define (prime? n)
+ (= n (smallest-divisor n)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+
+(search-for-primes 100000001 100000099)
+(search-for-primes 1000000001 1000000099)
+(search-for-primes 10000000001 10000000099)
+(search-for-primes 100000000001 100000000099)
+(search-for-primes 1000000000001 1000000000099)
+(search-for-primes 10000000000001 10000000000099)
+(search-for-primes 100000000000001 100000000000099)
+
+;; see spreadsheet ex1-23.ods for results
+;; Not quite half, but close enough. This is due to introducing an extra computation at each step due to having to evaluate one extra (next-divisor test-divisor) with each call on the procedure
blob - /dev/null
blob + fd243208d841417be40fc87c0e8bb8309fef6f52 (mode 644)
--- /dev/null
+++ ex1-23.scm~
+(defun search-for-primes (start end)
+ (let ((start (if (evenp start) (1+ start) start)))
+ (do ((i start (+ i 2)))
+ ((> i end))
+ (when (prime? i)
+ (format t "~d is prime~%" i)))))
+
+(time (dotimes (i 1000 t) (search-for-primes 1000 1019)))
blob - /dev/null
blob + 626befc242fc0679b51cf6bf87f767cb1e282616 (mode 644)
Binary files /dev/null and ex1-24.ods differ
blob - /dev/null
blob + b7eb24f24d6d743721de3c03a955083c45fd8da8 (mode 644)
--- /dev/null
+++ ex1-24.scm
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (fermat-test n)
+ (define (try-it a)
+ (= (expmod a n n) a))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (fast-prime? n times)
+ (cond ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+;; Exercise 1.24. Modify the timed-prime-test procedure of exercise 1.22 to use fast-prime? (the Fermat method), and test each of the 12 primes you found in that exercise. Since the Fermat test has (log n) growth, how would you expect the time to test primes near 1,000,000 to compare with the time needed to test primes near 1000? Do your data bear this out? Can you explain any discrepancy you find?
+
+;; (define (smallest-divisor n)
+;; (find-divisor n 2))
+;; (define (find-divisor n test-divisor)
+;; (define (next-divisor n)
+;; (if (= n 2)
+;; 3
+;; (+ n 2)))
+;; (cond ((> (square test-divisor) n) n)
+;; ((divides? test-divisor n) test-divisor)
+;; (else (find-divisor n (next-divisor test-divisor)))))
+;; (define (divides? a b)
+;; (= (remainder b a) 0))
+;; (define (prime? n)
+;; (= n (smallest-divisor n)))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+
+(search-for-primes 100000000000001 100000000000099)
+(search-for-primes 1000000000000001 1000000000000099)
+(search-for-primes 10000000000000001 10000000000000099)
+(search-for-primes 100000000000000001 100000000000000099)
+(search-for-primes 1000000000000000001 1000000000000000099)
+(search-for-primes 10000000000000000001 10000000000000000099)
+
+;;can't even test due to small numbers being too fast
+
blob - /dev/null
blob + c6347f520e333ba233b035378dce46a835cc0164 (mode 644)
--- /dev/null
+++ ex1-24.scm~
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (fermat-test n)
+ (define (try-it a)
+ (= (expmod a n n) a))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (fast-prime? n times)
+ (cond ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+;; Exercise 1.24. Modify the timed-prime-test procedure of exercise 1.22 to use fast-prime? (the Fermat method), and test each of the 12 primes you found in that exercise. Since the Fermat test has (log n) growth, how would you expect the time to test primes near 1,000,000 to compare with the time needed to test primes near 1000? Do your data bear this out? Can you explain any discrepancy you find?
+
+;; (define (smallest-divisor n)
+;; (find-divisor n 2))
+;; (define (find-divisor n test-divisor)
+;; (define (next-divisor n)
+;; (if (= n 2)
+;; 3
+;; (+ n 2)))
+;; (cond ((> (square test-divisor) n) n)
+;; ((divides? test-divisor n) test-divisor)
+;; (else (find-divisor n (next-divisor test-divisor)))))
+;; (define (divides? a b)
+;; (= (remainder b a) 0))
+;; (define (prime? n)
+;; (= n (smallest-divisor n)))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+
+(search-for-primes 100000000000001 100000000000099)
+(search-for-primes 1000000000000001 1000000000000099)
+(search-for-primes 10000000000000001 10000000000000099)
+(search-for-primes 100000000000000001 100000000000000099)
+(search-for-primes 1000000000000000001 1000000000000000099)
+(search-for-primes 10000000000000000001 10000000000000000099)
+
+
+;;can't even test due to small numbers being too fast, large numbers being too large to be represented
+
blob - /dev/null
blob + a560eac21114a4389409303db477c49c6e72260a (mode 644)
--- /dev/null
+++ ex1-25.scm
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (fermat-test n)
+ (define (try-it a)
+ (= (expmod a n n) a))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (fast-prime? n times)
+ (cond ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+;; Exercise 1.24. Modify the timed-prime-test procedure of exercise 1.22 to use fast-prime? (the Fermat method), and test each of the 12 primes you found in that exercise. Since the Fermat test has (log n) growth, how would you expect the time to test primes near 1,000,000 to compare with the time needed to test primes near 1000? Do your data bear this out? Can you explain any discrepancy you find?
+
+;; (define (smallest-divisor n)
+;; (find-divisor n 2))
+;; (define (find-divisor n test-divisor)
+;; (define (next-divisor n)
+;; (if (= n 2)
+;; 3
+;; (+ n 2)))
+;; (cond ((> (square test-divisor) n) n)
+;; ((divides? test-divisor n) test-divisor)
+;; (else (find-divisor n (next-divisor test-divisor)))))
+;; (define (divides? a b)
+;; (= (remainder b a) 0))
+;; (define (prime? n)
+;; (= n (smallest-divisor n)))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+(search-for-primes 100000000000001 100000000000099)
+(search-for-primes 1000000000000001 1000000000000099)
+(search-for-primes 10000000000000001 10000000000000099)
+(search-for-primes 100000000000000001 100000000000000099)
+(search-for-primes 1000000000000000001 1000000000000000099)
+(search-for-primes 10000000000000000001 10000000000000000099)
+
+;; Exercise 1.25. Alyssa P. Hacker complains that we went to a lot of extra work in writing expmod. After all, she says, since we already know how to compute exponentials, we could have simply written
+
+;; (define (expmod base exp m)
+;; (remainder (fast-expt base exp) m))
+
+;; Is she correct? Would this procedure serve as well for our fast prime tester? Explain.
+
+(define (expmod base exp m)
+ (remainder (fast-expt base exp) m))
+
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+;; Calculating exponentials using (fast-expt ...) gets slower and slower since we are calculating absolutely huge exponents (base^10000000... and higher). Doing multiplication requires more steps as the exponents get bigger, which is why using (expmod) is a huge benefit. The actual multiplications are never bigger than m.
blob - /dev/null
blob + 365e19d77826864cf33b1be160037526152a210f (mode 644)
--- /dev/null
+++ ex1-25.scm~
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (fermat-test n)
+ (define (try-it a)
+ (= (expmod a n n) a))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (fast-prime? n times)
+ (cond ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+;; Exercise 1.24. Modify the timed-prime-test procedure of exercise 1.22 to use fast-prime? (the Fermat method), and test each of the 12 primes you found in that exercise. Since the Fermat test has (log n) growth, how would you expect the time to test primes near 1,000,000 to compare with the time needed to test primes near 1000? Do your data bear this out? Can you explain any discrepancy you find?
+
+;; (define (smallest-divisor n)
+;; (find-divisor n 2))
+;; (define (find-divisor n test-divisor)
+;; (define (next-divisor n)
+;; (if (= n 2)
+;; 3
+;; (+ n 2)))
+;; (cond ((> (square test-divisor) n) n)
+;; ((divides? test-divisor n) test-divisor)
+;; (else (find-divisor n (next-divisor test-divisor)))))
+;; (define (divides? a b)
+;; (= (remainder b a) 0))
+;; (define (prime? n)
+;; (= n (smallest-divisor n)))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+
+(search-for-primes 1000000000001 100000000099)
+(search-for-primes 10000000000001 1000000000099)
+(search-for-primes 100000000000001 10000000000099)
+(search-for-primes 1000000000000001 100000000000099)
+(search-for-primes 10000000000000001 1000000000000099)
+(search-for-primes 100000000000000001 10000000000000099)
+
+;; Exercise 1.25. Alyssa P. Hacker complains that we went to a lot of extra work in writing expmod. After all, she says, since we already know how to compute exponentials, we could have simply written
+
+;; (define (expmod base exp m)
+;; (remainder (fast-expt base exp) m))
+
+;; Is she correct? Would this procedure serve as well for our fast prime tester? Explain.
blob - /dev/null
blob + c5c89fd781a5488a1c93d54d14fa25428cfdc9b1 (mode 644)
--- /dev/null
+++ ex1-26.lisp
+(setf custom:*trace-indent* 1)
+
+(trace expmod)
+(expmod 15 10 10)
+((defun louid-expmod (base exponent m)
+ (cond ((= exponent 0) 1)
+ ((evenp exponent)
+ (rem (* (louis-expmod base (/ exponent 2) m)
+ (louid-expmod base (/ exponent 2) m))
+ m))
+ (t (rem (* base louid-expmod base (- exponent 1) m))
+ m))))
blob - /dev/null
blob + 3c948a5b60b6ddedddffaa8877852c656c9d65e4 (mode 644)
--- /dev/null
+++ ex1-26.lisp~
+(setf custom:*trace-indent* 1)
+
+(trace expmod)
+(expmod 15 10 10)
+((defun louid-expmod (base exponent m)
+ (cond ((= exponent 0) 1)
+ ((evenp exponent)
+ (rem (* (louis-expmod base (/ exponent 2) m)
+ (louid-expmod base (/ exponent 2) m))
+ m))
+ (t (rem (* base louid-expmod base (- exponent 1) m)) m))))
blob - /dev/null
blob + c5c5502df313593611f71c9f3f6410b016e0d19a (mode 644)
--- /dev/null
+++ ex1-26.scm
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (fermat-test n)
+ (define (try-it a)
+ (= (expmod a n n) a))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (fast-prime? n times)
+ (cond ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+(search-for-primes 100000000000001 100000000000099)
+(search-for-primes 1000000000000001 1000000000000099)
+(search-for-primes 10000000000000001 10000000000000099)
+(search-for-primes 100000000000000001 100000000000000099)
+(search-for-primes 1000000000000000001 1000000000000000099)
+(search-for-primes 10000000000000000001 10000000000000000099)
+
+;; Exercise 1.26. Louis Reasoner is having great difficulty doing exercise 1.24. His fast-prime? test seems to run more slowly than his prime? test. Louis calls his friend Eva Lu Ator over to help. When they examine Louis's code, they find that he has rewritten the expmod procedure to use an explicit multiplication, rather than calling square:
+
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (* (expmod base (/ exp 2) m)
+ (expmod base (/ exp 2) m))
+ m))
+ (else
+ (remainder (* base (expmod base (- exp 1) m))
+ m))))
+
+;;``I don't see what difference that could make,'' says Louis. ``I do.'' says Eva. ``By writing the procedure like that, you have transformed the (log n) process into a (n) process.'' Explain.
+
+;; Every time exp = 2, we have to calculate (expmod base (/ exp 2) m) twice instead of once. But this ultimately ends up creating lots more calls because this occurs at each procedure call where exp = 2. In total, there will be 'exp' number of alls rather than the original roughly log(exp) number of calls.
+n
+;; We used to have a linear(??) recursion at each step but now have a tree(??) recursion. It used to be O(log) but because it increase exponentially, it is back to the order of exp.
blob - /dev/null
blob + c5c5502df313593611f71c9f3f6410b016e0d19a (mode 644)
--- /dev/null
+++ ex1-26.scm~
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (fermat-test n)
+ (define (try-it a)
+ (= (expmod a n n) a))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (fast-prime? n times)
+ (cond ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+(search-for-primes 100000000000001 100000000000099)
+(search-for-primes 1000000000000001 1000000000000099)
+(search-for-primes 10000000000000001 10000000000000099)
+(search-for-primes 100000000000000001 100000000000000099)
+(search-for-primes 1000000000000000001 1000000000000000099)
+(search-for-primes 10000000000000000001 10000000000000000099)
+
+;; Exercise 1.26. Louis Reasoner is having great difficulty doing exercise 1.24. His fast-prime? test seems to run more slowly than his prime? test. Louis calls his friend Eva Lu Ator over to help. When they examine Louis's code, they find that he has rewritten the expmod procedure to use an explicit multiplication, rather than calling square:
+
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (* (expmod base (/ exp 2) m)
+ (expmod base (/ exp 2) m))
+ m))
+ (else
+ (remainder (* base (expmod base (- exp 1) m))
+ m))))
+
+;;``I don't see what difference that could make,'' says Louis. ``I do.'' says Eva. ``By writing the procedure like that, you have transformed the (log n) process into a (n) process.'' Explain.
+
+;; Every time exp = 2, we have to calculate (expmod base (/ exp 2) m) twice instead of once. But this ultimately ends up creating lots more calls because this occurs at each procedure call where exp = 2. In total, there will be 'exp' number of alls rather than the original roughly log(exp) number of calls.
+n
+;; We used to have a linear(??) recursion at each step but now have a tree(??) recursion. It used to be O(log) but because it increase exponentially, it is back to the order of exp.
blob - /dev/null
blob + 0b4e03b7465c3238069eeec5caf4b270801cb19c (mode 644)
--- /dev/null
+++ ex1-27.lisp
+(defun full-fermat-test (n)
+ (defun aux-test (a)
+ (cond ((= a 1) t)
+ ((/= (expmod a n n) a) nil)
+ (t (aux-test (1- a)))))
+ (aux-test (1- n)))
+
+(full-fermat-test 6601)
blob - /dev/null
blob + 156b7fd641d126df862e4bb41e7fd2d83c0ee7e0 (mode 644)
--- /dev/null
+++ ex1-27.lisp~
+(defun full-fermat-test (n)
+ (defun aux-test (a)
+ (cond ((= a 1) t)
+ ((/= (expmod a n n) a) nil)
+ (t (aux-test (1- a)))))
+ (aux-test (1- n)))
blob - /dev/null
blob + fed4b05b62bb7aa0f02cdde694483622241e4def (mode 644)
--- /dev/null
+++ ex1-27.scm
+;; (define (expmod base exp m)
+;; (cond ((= exp 0) 1)
+;; ((even? exp)
+;; (remainder (square (expmod base (/ exp 2) m)) m))
+;; (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+;; (define (fermat-test n)
+;; (define (try-it a)
+;; (= (expmod a n n) a))
+;; (try-it (+ 1 (random (- n 1)))))
+
+;; (define (fast-prime? n times)
+;; (cond ((= times 0) true)
+;; ((fermat-test n) (fast-prime? n (- times 1)))
+;; (else false)))
+
+;; ;; (define (test-case actual expected)
+;; ;; (load-option 'format)
+;; ;; (newline)
+;; ;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (define (prime? n)
+;; (let ((times-to-test 10))
+;; (fast-prime? n times-to-test)))
+
+;; (define (timed-prime-test n)
+;; (newline)
+;; (display n)
+;; (start-prime-test n (runtime)))
+;; (define (start-prime-test n start-time)
+;; (if (prime? n)
+;; (report-prime (- (runtime) start-time))))
+;; (define (report-prime elapsed-time)
+;; (display " *** ")
+;; (display elapsed-time))
+
+;; (define (search-for-primes lower upper)
+;; (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+;; ((< lower upper) (begin (timed-prime-test lower)
+;; (search-for-primes (+ lower 2) upper)))
+;; (else (newline)
+;; (display " *** Finished *** "))))
+
+;; (search-for-primes 100000000000001 100000000000099)
+;; (search-for-primes 1000000000000001 1000000000000099)
+;; (search-for-primes 10000000000000001 10000000000000099)
+;; (search-for-primes 100000000000000001 100000000000000099)
+;; (search-for-primes 1000000000000000001 1000000000000000099)
+;; (search-for-primes 10000000000000000001 10000000000000000099)
+
+
+;; (define (fermat-test n)
+;; (define (try-it a)
+;; (= (expmod a n n) a))
+;; (try-it (+ 1 (random (- n 1)))))
+
+;; (define (fast-prime? n times)
+;; (cond ((= times 0) true)
+;; ((fermat-test n) (fast-prime? n (- times 1)))
+;; (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (define (prime? n)
+;; (let ((times-to-test 10))
+;; (fast-prime? n times-to-test)))
+
+;; (define (timed-prime-test n)
+;; (newline)
+;; (display n)
+;; (start-prime-test n (runtime)))
+;; (define (start-prime-test n start-time)
+;; (if (prime? n)
+;; (report-prime (- (runtime) start-time))))
+;; (define (report-prime elapsed-time)
+;; (display " *** ")
+;; (display elapsed-time))
+
+;; (define (search-for-primes lower upper)
+;; (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+;; ((< lower upper) (begin (timed-prime-test lower)
+;; (search-for-primes (+ lower 2) upper)))
+;; (else (newline)
+;; (display " *** Finished *** "))))
+
+
+
+
+
+;; Exercise 1.27. Demonstrate that the Carmichael numbers listed in footnote 47 really do fool the Fermat test. That is, write a procedure that takes an integer n and tests whether an is congruent to a modulo n for every a<n, and try your procedure on the given Carmichael numbers.
+
+;; Numbers that fool the Fermat test are called Carmichael numbers, and little is known about them other than that they are extremely rare. There are 255 Carmichael numbers below 100,000,000. The smallest few are 561, 1105, 1729, 2465, 2821, and 6601. In testing primality of very large numbers chosen at random, the chance of stumbling upon a value that fools the Fermat test is less than the chance that cosmic radiation will cause the computer to make an error in carrying out a ``correct'' algorithm. Considering an algorithm to be inadequate for the first reason but not for the second illustrates the difference between mathematics and engineering.
+
+;; calculate base^exp modulo m
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+;; tests if integer n passes fermat's little theorem
+(define (fermat-prime? n)
+ (define (fermat-test a)
+ (cond ((= a n) #t)
+ ((not (= (expmod a n n) a)) #f)
+ (else (fermat-test (+ a 1)))))
+ (fermat-test 1))
+
+(define (list-primes upper)
+ (define (test i)
+ (cond ((= i upper) (display "Finished"))
+ ((fermat-prime? i) (begin (display i)
+ (newline))))
+ (test (+ i 1)))
+ (test 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (fermat-prime? 2) #t)
+;; (test-case (fermat-prime? 3) #t)
+;; (test-case (fermat-prime? 4) #f)
+;; (test-case (fermat-prime? 5) #t)
+;; (test-case (fermat-prime? 6) #f)
+;; (test-case (fermat-prime? 7) #t)
+;; (test-case (fermat-prime? 8) #f)
+;; (test-case (fermat-prime? 9) #f)
+
+
+;; (list-primes 10000)
+
+;; Carmichael Numbers
+(test-case (fermat-prime? 561) #f)
+(test-case (fermat-prime? 1105) #f)
+(test-case (fermat-prime? 1729) #f)
+(test-case (fermat-prime? 2465) #f)
+(test-case (fermat-prime? 2821) #f)
+(test-case (fermat-prime? 6601) #f)
blob - /dev/null
blob + c5c5502df313593611f71c9f3f6410b016e0d19a (mode 644)
--- /dev/null
+++ ex1-27.scm~
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (fermat-test n)
+ (define (try-it a)
+ (= (expmod a n n) a))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (fast-prime? n times)
+ (cond ((= times 0) true)
+ ((fermat-test n) (fast-prime? n (- times 1)))
+ (else false)))
+
+;; (define (test-case actual expected)
+;; (load-option 'format)
+;; (newline)
+;; (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (prime? n)
+ (let ((times-to-test 10))
+ (fast-prime? n times-to-test)))
+
+(define (timed-prime-test n)
+ (newline)
+ (display n)
+ (start-prime-test n (runtime)))
+(define (start-prime-test n start-time)
+ (if (prime? n)
+ (report-prime (- (runtime) start-time))))
+(define (report-prime elapsed-time)
+ (display " *** ")
+ (display elapsed-time))
+
+(define (search-for-primes lower upper)
+ (cond ((even? lower) (search-for-primes (+ lower 1) upper))
+ ((< lower upper) (begin (timed-prime-test lower)
+ (search-for-primes (+ lower 2) upper)))
+ (else (newline)
+ (display " *** Finished *** "))))
+
+(search-for-primes 100000000000001 100000000000099)
+(search-for-primes 1000000000000001 1000000000000099)
+(search-for-primes 10000000000000001 10000000000000099)
+(search-for-primes 100000000000000001 100000000000000099)
+(search-for-primes 1000000000000000001 1000000000000000099)
+(search-for-primes 10000000000000000001 10000000000000000099)
+
+;; Exercise 1.26. Louis Reasoner is having great difficulty doing exercise 1.24. His fast-prime? test seems to run more slowly than his prime? test. Louis calls his friend Eva Lu Ator over to help. When they examine Louis's code, they find that he has rewritten the expmod procedure to use an explicit multiplication, rather than calling square:
+
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (* (expmod base (/ exp 2) m)
+ (expmod base (/ exp 2) m))
+ m))
+ (else
+ (remainder (* base (expmod base (- exp 1) m))
+ m))))
+
+;;``I don't see what difference that could make,'' says Louis. ``I do.'' says Eva. ``By writing the procedure like that, you have transformed the (log n) process into a (n) process.'' Explain.
+
+;; Every time exp = 2, we have to calculate (expmod base (/ exp 2) m) twice instead of once. But this ultimately ends up creating lots more calls because this occurs at each procedure call where exp = 2. In total, there will be 'exp' number of alls rather than the original roughly log(exp) number of calls.
+n
+;; We used to have a linear(??) recursion at each step but now have a tree(??) recursion. It used to be O(log) but because it increase exponentially, it is back to the order of exp.
blob - /dev/null
blob + d923538258f52936697b125522f8c350adbb316b (mode 644)
--- /dev/null
+++ ex1-28.scm
+;; Exercise 1.28. One variant of the Fermat test that cannot be fooled is called the Miller-Rabin test (Miller 1976; Rabin 1980). This starts from an alternate form of Fermat's Little Theorem, which states that if n is a prime number and a is any positive integer less than n, then a raised to the (n - 1)st power is congruent to 1 modulo n. To test the primality of a number n by the Miller-Rabin test, we pick a random number a<n and raise a to the (n - 1)st power modulo n using the expmod procedure. However, whenever we perform the squaring step in expmod, we check to see if we have discovered a ``nontrivial square root of 1 modulo n,'' that is, a number not equal to 1 or n - 1 whose square is equal to 1 modulo n. It is possible to prove that if such a nontrivial square root of 1 exists, then n is not prime. It is also possible to prove that if n is an odd number that is not prime, then, for at least half the numbers a<n, computing a^(n-1) in this way will reveal a nontrivial square root of 1 modulo n. (This is why the Miller-Rabin test cannot be fooled.) Modify the expmod procedure to signal if it discovers a nontrivial square root of 1, and use this to implement the Miller-Rabin test with a procedure analogous to fermat-test. Check your procedure by testing various known primes and non-primes. Hint: One convenient way to make expmod signal is to have it return 0.
+
+;; calculate base^exp modulo m but return 0 if nontrivial square root of 1 modulo n is discovered
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (let ((modulo-sqrt (expmod base (/ exp 2) m)))
+ (let ((modulo-sqr (remainder (square modulo-sqrt) m)))
+ (if (and (not (or (= modulo-sqrt 1) (= modulo-sqrt (- m 1))))
+ (= modulo-sqr 1))
+ 0
+ modulo-sqr))))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+(define (miller-rabin-test n)
+ (define (try-it a)
+ (= (expmod a (- n 1) n) 1))
+ (try-it (+ 1 (random (- n 1)))))
+
+(define (miller-rabin-prime? n times)
+ (cond ((= times 0) #t)
+ ((miller-rabin-test n) (miller-rabin-prime? n (- times 1)))
+ (else #f)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (quick-mr-prime? n)
+ (miller-rabin-prime? n 2500))
+
+;;(test-case (quick-mr-prime? 2) #t)
+(test-case (quick-mr-prime? 3) #t)
+(test-case (quick-mr-prime? 4) #f)
+(test-case (quick-mr-prime? 5) #t)
+(test-case (quick-mr-prime? 6) #f)
+(test-case (quick-mr-prime? 7) #t)
+(test-case (quick-mr-prime? 8) #f)
+(test-case (quick-mr-prime? 9) #f)
+
+;; (list-primes 10000)
+
+;; Carmichael Numbers
+(test-case (quick-mr-prime? 561) #f)
+(test-case (quick-mr-prime? 1105) #f)
+(test-case (quick-mr-prime? 1729) #f)
+(test-case (quick-mr-prime? 2465) #f)
+(test-case (quick-mr-prime? 2821) #f)
+(test-case (quick-mr-prime? 6601) #f)
blob - /dev/null
blob + 857dc841bf4e31520ae0b29fdbfc09a364069dcc (mode 644)
--- /dev/null
+++ ex1-28.scm~
+;; calculate base^exp modulo m
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
+
+;; tests if integer n passes fermat's little theorem
+(define (fermat-prime? n)
+ (define (fermat-test a)
+ (cond ((= a n) #t)
+ ((not (= (expmod a n n) a)) #f)
+ (else (fermat-test (+ a 1)))))
+ (fermat-test 1))
+
+(define (list-primes upper)
+ (define (test i)
+ (cond ((= i upper) (display "Finished"))
+ ((fermat-prime? i) (begin (display i)
+ (newline))))
+ (test (+ i 1)))
+ (test 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (fermat-prime? 2) #t)
+;; (test-case (fermat-prime? 3) #t)
+;; (test-case (fermat-prime? 4) #f)
+;; (test-case (fermat-prime? 5) #t)
+;; (test-case (fermat-prime? 6) #f)
+;; (test-case (fermat-prime? 7) #t)
+;; (test-case (fermat-prime? 8) #f)
+;; (test-case (fermat-prime? 9) #f)
+
+
+;; (list-primes 10000)
+
+;; Carmichael Numbers
+(test-case (fermat-prime? 561) #f)
+(test-case (fermat-prime? 1105) #f)
+(test-case (fermat-prime? 1729) #f)
+(test-case (fermat-prime? 2465) #f)
+(test-case (fermat-prime? 2821) #f)
+(test-case (fermat-prime? 6601) #f)
+
+
+;; Exercise 1.28. One variant of the Fermat test that cannot be fooled is called the Miller-Rabin test (Miller 1976; Rabin 1980). This starts from an alternate form of Fermat's Little Theorem, which states that if n is a prime number and a is any positive integer less than n, then a raised to the (n - 1)st power is congruent to 1 modulo n. To test the primality of a number n by the Miller-Rabin test, we pick a random number a<n and raise a to the (n - 1)st power modulo n using the expmod procedure. However, whenever we perform the squaring step in expmod, we check to see if we have discovered a ``nontrivial square root of 1 modulo n,'' that is, a number not equal to 1 or n - 1 whose square is equal to 1 modulo n. It is possible to prove that if such a nontrivial square root of 1 exists, then n is not prime. It is also possible to prove that if n is an odd number that is not prime, then, for at least half the numbers a<n, computing a^(n-1) in this way will reveal a nontrivial square root of 1 modulo n. (This is why the Miller-Rabin test cannot be fooled.) Modify the expmod procedure to signal if it discovers a nontrivial square root of 1, and use this to implement the Miller-Rabin test with a procedure analogous to fermat-test. Check your procedure by testing various known primes and non-primes. Hint: One convenient way to make expmod signal is to have it return 0.
+
+(expmod base exp m)
+(= (expmod a (n-1) n) 1)
+
+;; calculate base^exp modulo m but signal if
+(define (expmod base exp m)
+ (cond ((= exp 0) 1)
+ ((even? exp)
+ (remainder (square (expmod base (/ exp 2) m)) m))
+ (else (remainder (* base (expmod base (- exp 1) m)) m))))
blob - /dev/null
blob + 8435f22762a4f7417f9d93b58ddd7fda15be8053 (mode 644)
--- /dev/null
+++ ex1-29.lisp
+(defun cube (x)
+ (* x x x))
+(defun sum (term a next b)
+ (if (> a b)
+ 0
+ (+ (funcall term a)
+ (sum term (funcall next a) next b))))
+(defun sum-integers (a b)
+ (sum #'identity a #'1+ b))
+(defun pi-sum (a b)
+ (defun pi-term (x)
+ (/ 1.0 (* x (+ x 2))))
+ (defun pi-next (x)
+ (+ x 4))
+ (sum #'pi-term a #'pi-next b))
+(defun integral (f a b dx)
+ (defun add-dx (x)
+ (+ x dx))
+ (* (sum f (+ a (/ dx 2.0)) #'add-dx b) dx))
+
+(defun simpson-integral (f a b n)
+ (let ((h (float (/ (- b a) n))))
+ (defun simpson-term (k)
+ (* (funcall f (+ a (* k h)))
+ (cond ((or (= k 0) (= k n)) 1)
+ ((oddp k) 4)
+ (t 2))))
+ (* (/ h 3)
+ (sum #'simpson-term 0 #'1+ n))))
blob - /dev/null
blob + fa34e700a5de8617a07743617d92aecb2319bde4 (mode 644)
--- /dev/null
+++ ex1-29.lisp~
+(defun cube (x)
+ (* x x x))
+(defun sum (term a next b)
+ (if (> a b)
+ 0
+ (+ (funcall term a)
+ (sum term (funcall next a) next b))))
+(defun sum-integers (a b)
+ (sum #'identity a #'1+ b))
+(defun pi-sum (a b)
+ (defun pi-term (x)
+ (/ 1.0 (* x (+ x 2))))
+ (defun pi-next (x)
+ (+ x 4))
+ (sum #'pi-term a #'pi-next b))
+(defun integral (f a b dx)
+ (defun add-dx (x)
+ (+ x dx))
+ (* (sum f (+ a (/ dx 2.0)) #'add-dx b) dx))
blob - /dev/null
blob + 35a7f803e0d3197d31240c0d9d881495b450ee2f (mode 644)
--- /dev/null
+++ ex1-29.scm
+(define (sum term a next b)
+ (if (> a b)
+ 0
+ (+ (term a)
+ (sum term (next a) next b))))
+
+;; (define (simpsons-rule f a b n)
+;; (let ((h (/ (- b a) n)))
+;; (define (running-sum k)
+;; (let ((akh (+ a (* k h))))
+;; (if (= k n)
+;; (f akh)
+;; (+ (cond ((= k 0) (f akh))
+;; ((even? k) (* 2 (f akh)))
+;; ((odd? k) (* 4 (f akh))))
+;; (running-sum (+ k 1))))))
+;; (* (/ h 3)
+;; (running-sum 0))))
+
+(define (simpsons-rule f a b n)
+ (let ((h (/ (- b a) n)))
+ (define (simpsons-term k)
+ (let ((akh (+ a (* k h))))
+ (* (f akh)
+ (cond ((or (= k 0) (= k n)) 1)
+ ((odd? k) 4)
+ ((even? k) 2)))))
+ (* (/ h 3)
+ (sum simpsons-term 0 1+ n))))
+
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (cube x) (* x x x))
+
+(test-case (simpsons-rule cube 0.0 1.0 5) 0.25)
+(test-case (simpsons-rule cube 0.0 1.0 10) 0.25)
+(test-case (simpsons-rule cube 0.0 1.0 100) 0.25)
+
blob - /dev/null
blob + fe38efd0859d86c6cafa7485d05c88f2373ce963 (mode 644)
--- /dev/null
+++ ex1-29.scm~
+(define (sum term a next b)
+ (if (> a b)
+ 0
+ (+ (term a)
+ (sum term (next a) next b))))
blob - /dev/null
blob + fc585a7f36da66fc925e8b3c5179829615c5c19d (mode 644)
--- /dev/null
+++ ex1-3.scm
+(define (square x) (* x x))
+(define (sum-of-squares x y) (+ (square x) (square y)))
+(define (sum-sqr-two-larger x y z)
+ (cond ((and (> x z) (> y z)) (sum-of-squares x y))
+ ((and (> x y) (> z y)) (sum-of-squares x z))
+ (else (sum-of-squares y z))))
+(sum-sqr-two-larger 1 2 3)
+13
+(sum-sqr-two-larger 4 3 9)
+97
+(sum-sqr-two-larger 7 3 1)
+58
blob - /dev/null
blob + 01f13f26243dc6df294a378399c118c93cf63b22 (mode 644)
--- /dev/null
+++ ex1-3.scm~
+(define (square x) (* x x))
+(define (sum-sqr-two-larger x y z)
+ (cond (> x y z) (square x x)
\ No newline at end of file
blob - /dev/null
blob + c58a4d00e1e0894e2496002ffcf79f4d7b7115e4 (mode 644)
--- /dev/null
+++ ex1-30.lisp
+(defun sum-iter (term a next b)
+ (defun iter (a result)
+ (if (> a b)
+ result
+ (iter (funcall next a)
+ (+ (funcall term a) result))))
+ (iter a 0))
blob - /dev/null
blob + de556bc211441e0e23d23282cd6e913a6544197c (mode 644)
--- /dev/null
+++ ex1-30.scm
+;; Exercise 1.30. The sum procedure above generates a linear recursion. The procedure can be rewritten so that the sum is performed iteratively. Show how to do this by filling in the missing expressions in the following definition:
+
+(define (sum term a next b)
+ (define (iter a result)
+ (if (> a b)
+ result
+ (iter (next a) (+ (term a) result))))
+ (iter a 0))
+
+(define (integral f a b dx)
+ (define (add-dx x) (+ x dx))
+ (* (sum f (+ a (/ dx 2.0)) add-dx b)
+ dx))
+
+(define (cube x) (* x x x))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+
+(test-case (integral cube 0.0 1.0 0.001) 0.25)
blob - /dev/null
blob + 645bbfe947d3acb9e43998af00fd1ac767e1d27f (mode 644)
--- /dev/null
+++ ex1-30.scm~
+ Exercise 1.30. The sum procedure above generates a linear recursion. The procedure can be rewritten so that the sum is performed iteratively. Show how to do this by filling in the missing expressions in the following definition:
+
+(define (sum term a next b)
+ (define (iter a result)
+ (if <??>
+ <??>
+ (iter <??> <??>)))
+ (iter <??> <??>))
blob - /dev/null
blob + ea613e474f25da91e89f1710b41ece8f8cd2f323 (mode 644)
--- /dev/null
+++ ex1-31.lisp
+(defun product (term a next b)
+ (if (> a b)
+ 1
+ (* (funcall term a)
+ (product term (funcall next a) next b))))
+(defun factorial (n)
+ (product #'identity 1 #'1+ n))
+(defun wallis-pi (n)
+ (defun wallis-term (k)
+ (let ((nom
+ (if (evenp k)
+ (+ k 2)
+ (+ k 1)))
+ (denom
+ (if (evenp k)
+ (+ k 1)
+ (+ k 2))))
+ (float (/ nom denom))))
+ (* (product #'wallis-term 1 #'1+ n)))
+
+(defun product-iter (term a next b)
+ (defun iter (a result)
+ (if (> a b)
+ result
+ (iter (funcall next a)
+ (* (funcall term a) result))))
+ (iter a 1))
+
blob - /dev/null
blob + fa7368935691901ae8f4d45d250c1c98402f1a40 (mode 644)
--- /dev/null
+++ ex1-31.lisp~
+(defun product (term a next b)
+ (if (> a b)
+ 1
+ (* (funcall term a)
+ (product term (funcall next a) next b))))
blob - /dev/null
blob + 1fdf1a4c261602f09a8defdefbfc40bbc2a536f7 (mode 644)
--- /dev/null
+++ ex1-31.scm
+;; Exercise 1.30. The sum procedure above generates a linear recursion. The procedure can be rewritten so that the sum is performed iteratively. Show how to do this by filling in the missing expressions in the following definition:
+
+(define (product term a next b)
+ (if (> a b)
+ 1
+ (* (term a)
+ (product term (next a) next b))))
+
+(define (product-iter term a next b)
+ (define (iter i result)
+ (if (> i b)
+ result
+ (iter (next i) (* (term i) result))))
+ (iter a 1))
+
+(define (factorial n)
+ (product (lambda (x) x)
+ 1
+ (lambda (x) (+ x 1))
+ n))
+
+(define (factorial-iter n)
+ (product-iter (lambda (x) x)
+ 1
+ (lambda (x) (+ x 1))
+ n))
+
+;; pi/4 = 2*4*4*6*6*8*...
+;; ---------------
+;; 3*3*5*5*7*7*...
+
+(define (pi iterations)
+ (* 4.0
+ (product (lambda (x)
+ (if (odd? x)
+ (/ (+ x 1) (+ x 2))
+ (/ (+ x 2) (+ x 1))))
+ 1
+ (lambda (x) (+ x 1))
+ iterations)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (factorial 0) 1)
+(test-case (factorial 1) 1)
+(test-case (factorial 2) 2)
+(test-case (factorial 3) 6)
+(test-case (factorial 4) 24)
+(test-case (factorial 5) 120)
+(test-case (factorial 6) 720)
+(test-case (factorial 7) 5040)
+(test-case (factorial-iter 7) 5040)
+
+(test-case (pi 10000) 3.1415)
blob - /dev/null
blob + de556bc211441e0e23d23282cd6e913a6544197c (mode 644)
--- /dev/null
+++ ex1-31.scm~
+;; Exercise 1.30. The sum procedure above generates a linear recursion. The procedure can be rewritten so that the sum is performed iteratively. Show how to do this by filling in the missing expressions in the following definition:
+
+(define (sum term a next b)
+ (define (iter a result)
+ (if (> a b)
+ result
+ (iter (next a) (+ (term a) result))))
+ (iter a 0))
+
+(define (integral f a b dx)
+ (define (add-dx x) (+ x dx))
+ (* (sum f (+ a (/ dx 2.0)) add-dx b)
+ dx))
+
+(define (cube x) (* x x x))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+
+
+(test-case (integral cube 0.0 1.0 0.001) 0.25)
blob - /dev/null
blob + 97ee188536a74e10815f6f1eda102f2f0c3198ea (mode 644)
--- /dev/null
+++ ex1-32.lisp
+(defun accumulator (combiner null-value term a next b)
+ (if (> a b)
+ null-value
+ (funcall combiner
+ (funcall term a)
+ (accumulator combiner null-value term (funcall next a) next b))))
+(defun sum (term a next b)
+ (accumulator #'+ 0 term a next b))
+(defun accumulator-iter (combiner null-value term a next b)
+ (defun iter (a result)
+ (if (> a b)
+ result
+ (iter (funcall next a)
+ (funcall combiner (funcall term a) result))))
+ (iter a null-value))
+(defun product (term a next b)
+ (accumulator-iter #'* 1 term a next b))
blob - /dev/null
blob + 2cd0140136b89f0690ecaa6c80a47f3cfc57910c (mode 644)
--- /dev/null
+++ ex1-32.lisp~
+(defun accumulator (combiner null-value term a next b)
+ (if (> a b)
+ null-value
+ (funcall combiner
+ (funcall term a)
+ (accumulator combiner null-value term (funcall next a) next b))))
+(defun sum (term a next b)
+ (accumulator #'+ 0 term a next b))
+(defun accumulator-iter (combiner null-value term a next b)
+ (defun iter (a result)
+ (if (> a b)
+ result
+ (iter (funcall next a)
+ (funcall combiner (funcall term a) result))))
blob - /dev/null
blob + 6e14060e6a5ec7f0a4615928a938b39bb54db42f (mode 644)
--- /dev/null
+++ ex1-32.scm
+;; Exercise 1.32. a. Show that sum and product (exercise 1.31) are both special cases of a still more general notion called accumulate that combines a collection of terms, using some general accumulation function:
+
+;; (accumulate combiner null-value term a next b)
+
+;; Accumulate takes as arguments the same term and range specifications as sum and product, together with a combiner procedure (of two arguments) that specifies how the current term is to be combined with the accumulation of the preceding terms and a null-value that specifies what base value to use when the terms run out. Write accumulate and show how sum and product can both be defined as simple calls to accumulate.
+
+(define (accumulate combiner null-value term a next b)
+ (if (> a b)
+ null-value
+ (combiner (term a)
+ (accumulate combiner null-value term (next a) next b))))
+
+(define (sum term a next b)
+ (accumulate + 0 term a next b))
+(define (product term a next b)
+ (accumulate * 1 term a next b))
+
+
+(define (accumulate combiner null-value term a next b)
+ (if (> a b)
+ null-value
+ (combiner (term a)
+ (accumulate combiner null-value term (next a) next b))))
+
+;; b. If your accumulate procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
+
+(define (accumulate-iter combiner null-value term a next b)
+ (define (iter i result)
+ (if (> a b)
+ result
+ (iter (next i) (combiner (term i) result))))
+ (iter a null-value))
+
+
+(define (factorial n)
+ (product (lambda (x) x)
+ 1
+ (lambda (x) (+ x 1))
+ n))
+
+(define (factorial-iter n)
+ (product-iter (lambda (x) x)
+ 1
+ (lambda (x) (+ x 1))
+ n))
+
+;; pi/4 = 2*4*4*6*6*8*...
+;; ---------------
+;; 3*3*5*5*7*7*...
+
+(define (pi iterations)
+ (* 4.0
+ (product (lambda (x)
+ (if (odd? x)
+ (/ (+ x 1) (+ x 2))
+ (/ (+ x 2) (+ x 1))))
+ 1
+ (lambda (x) (+ x 1))
+ iterations)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (factorial 0) 1)
+(test-case (factorial 1) 1)
+(test-case (factorial 2) 2)
+(test-case (factorial 3) 6)
+(test-case (factorial 4) 24)
+(test-case (factorial 5) 120)
+(test-case (factorial 6) 720)
+(test-case (factorial 7) 5040)
+(test-case (factorial-iter 7) 5040)
+
+(test-case (pi 10000) 3.1415)
+
+
+
blob - /dev/null
blob + 1fdf1a4c261602f09a8defdefbfc40bbc2a536f7 (mode 644)
--- /dev/null
+++ ex1-32.scm~
+;; Exercise 1.30. The sum procedure above generates a linear recursion. The procedure can be rewritten so that the sum is performed iteratively. Show how to do this by filling in the missing expressions in the following definition:
+
+(define (product term a next b)
+ (if (> a b)
+ 1
+ (* (term a)
+ (product term (next a) next b))))
+
+(define (product-iter term a next b)
+ (define (iter i result)
+ (if (> i b)
+ result
+ (iter (next i) (* (term i) result))))
+ (iter a 1))
+
+(define (factorial n)
+ (product (lambda (x) x)
+ 1
+ (lambda (x) (+ x 1))
+ n))
+
+(define (factorial-iter n)
+ (product-iter (lambda (x) x)
+ 1
+ (lambda (x) (+ x 1))
+ n))
+
+;; pi/4 = 2*4*4*6*6*8*...
+;; ---------------
+;; 3*3*5*5*7*7*...
+
+(define (pi iterations)
+ (* 4.0
+ (product (lambda (x)
+ (if (odd? x)
+ (/ (+ x 1) (+ x 2))
+ (/ (+ x 2) (+ x 1))))
+ 1
+ (lambda (x) (+ x 1))
+ iterations)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (factorial 0) 1)
+(test-case (factorial 1) 1)
+(test-case (factorial 2) 2)
+(test-case (factorial 3) 6)
+(test-case (factorial 4) 24)
+(test-case (factorial 5) 120)
+(test-case (factorial 6) 720)
+(test-case (factorial 7) 5040)
+(test-case (factorial-iter 7) 5040)
+
+(test-case (pi 10000) 3.1415)
blob - /dev/null
blob + 6d6791eccdf8a79f3566435e272d706ae299e1ca (mode 644)
--- /dev/null
+++ ex1-33.lisp
+(defun filtered-accumulator (combiner null-value term a next b filter)
+ (cond ((> a b) null-value)
+ ((funcall filter a)
+ (funcall combiner
+ (funcall term a)
+ (filtered-accumulator combiner null-value term (funcall next a) next b filter)))
+ (t (filtered-accumulator combiner null-value term (funcall next a) next b filter))))
+(defun sum-squares-of-primes (a b)
+ (filtered-accumulator #'+ 0 #'square a #'1+ b #'prime?))
+(defun product-of-relatively-prime (n)
+ (defun relatively-prime-to-n? (k)
+ (= (gcd k n) 1))
+ (filtered-accumulator #'* 1 #'identity 1 #'1+ (1- n) #'relatively-prime-to-n?))
blob - /dev/null
blob + f4bab0a3b9742d457ad0cfa9c7a28857d5313dd5 (mode 644)
--- /dev/null
+++ ex1-33.scm
+;; Exercise 1.33. You can obtain an even more general version of accumulate (exercise 1.32) by introducing the notion of a filter on the terms to be combined. That is, combine only those terms derived from values in the range that satisfy a specified condition. The resulting filtered-accumulate abstraction takes the same arguments as accumulate, together with an additional predicate of one argument that specifies the filter. Write filtered-accumulate as a procedure. Show how to express the following using filtered-accumulate:
+
+
+
+(define (filtered-accumulate combiner filter null-value term a next b)
+ (if (> a b)
+ null-value
+ (if (filter a)
+ (combiner (term a)
+ (filtered-accumulate combiner filter null-value term (next a) next b))
+ (filtered-accumulate combiner filter null-value term (next a) next b))))
+
+(define (sum-prime-squares a b)
+ (filtered-accumulate +
+ prime?
+ 0
+ (lambda (x) (* x x))
+ a
+ 1+
+ b))
+
+(define (smallest-divisor n)
+ (find-divisor n 2))
+
+(define (find-divisor n test-divisor)
+ (cond ((> (square test-divisor) n) n)
+ (( divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1)))))
+
+(define (divides? a b)
+ (= (remainder b a) 0))
+
+(define (prime? n)
+ (= n (smallest-divisor n)))
+
+
+;; (define (accumulate combiner null-value term a next b)
+;; (if (> a b)
+;; null-value
+;; (combiner (term a)
+;; (accumulate combiner null-value term (next a) next b))))
+
+;; (define (sum term a next b)
+;; (accumulate + 0 term a next b))
+;; (define (product term a next b)
+;; (accumulate * 1 term a next b))
+
+
+;; (define (accumulate combiner null-value term a next b)
+;; (if (> a b)
+;; null-value
+;; (combiner (term a)
+;; (accumulate combiner null-value term (next a) next b))))
+
+;; (define (accumulate-iter combiner null-value term a next b)
+;; (define (iter i result)
+;; (if (> a b)
+;; result
+;; (iter (next i) (combiner (term i) result))))
+;; (iter a null-value))
+
+
+;; (define (factorial n)
+;; (product (lambda (x) x)
+;; 1
+;; (lambda (x) (+ x 1))
+;; n))
+
+;; (define (factorial-iter n)
+;; (product-iter (lambda (x) x)
+;; 1
+;; (lambda (x) (+ x 1))
+;; n))
+
+;; pi/4 = 2*4*4*6*6*8*...
+;; ---------------
+;; 3*3*5*5*7*7*...
+
+;; (define (pi iterations)
+;; (* 4.0
+;; (product (lambda (x)
+;; (if (odd? x)
+;; (/ (+ x 1) (+ x 2))
+;; (/ (+ x 2) (+ x 1))))
+;; 1
+;; (lambda (x) (+ x 1))
+;; iterations)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (factorial 0) 1)
+;; (test-case (factorial 1) 1)
+;; (test-case (factorial 2) 2)
+;; (test-case (factorial 3) 6)
+;; (test-case (factorial 4) 24)
+;; (test-case (factorial 5) 120)
+;; (test-case (factorial 6) 720)
+;; (test-case (factorial 7) 5040)
+;; (test-case (factorial-iter 7) 5040)
+
+;; (test-case (pi 10000) 3.1415)
+
+;; a. the sum of the squares of the prime numbers in the interval a to b (assuming that you have a prime? predicate already written)
+
+;; b. the product of all the positive integers less than n that are relatively prime to n (i.e., all positive integers i < n such that GCD(i,n) = 1).
+
+(test-case (sum-prime-squares 2 17) 666)
+
+(define (relatively-prime-product n)
+ (filtered-accumulate *
+ (lambda (i)
+ (= (gcd i n) 1))
+ 1
+ (lambda (x) x)
+ 1
+ 1+
+ n))
+
+(define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+
+(test-case (relatively-prime-product 20) 8729721)
blob - /dev/null
blob + 97ee188536a74e10815f6f1eda102f2f0c3198ea (mode 644)
--- /dev/null
+++ ex1-33.scm~
+(defun accumulator (combiner null-value term a next b)
+ (if (> a b)
+ null-value
+ (funcall combiner
+ (funcall term a)
+ (accumulator combiner null-value term (funcall next a) next b))))
+(defun sum (term a next b)
+ (accumulator #'+ 0 term a next b))
+(defun accumulator-iter (combiner null-value term a next b)
+ (defun iter (a result)
+ (if (> a b)
+ result
+ (iter (funcall next a)
+ (funcall combiner (funcall term a) result))))
+ (iter a null-value))
+(defun product (term a next b)
+ (accumulator-iter #'* 1 term a next b))
blob - /dev/null
blob + ec35417c12921263d227548fd3ce0b18cb763be6 (mode 644)
--- /dev/null
+++ ex1-34.lisp
+(defvar tolerance 0.00001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (try (guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defun average (a b)
+ (/ (+ a b) 2))
+(defun dampen-sqrt (x)
+ (fixed-point
+ (lambda (y)
+ (average y (/ x y)))
+ 1.0))
+
+(fixed-point (lambda (x) (1+ (/1 x))) 1.0)
+
+(defvar tolerance 0.00001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (try (guess)
+ (format t "Trying ~F~%" guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defun average (a b)
+ (/ (+ a b) 2))
+(defun xx (x)
+ (/ (log 1000) (log x)))
+(defun dampen-xx (x)
+ (average x (xx x)))
+(print (fixed-point #'xx 2.0))
+(print (fixed-point #'dampen-xx 2.0))
+
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 66b3fb497a0079f0b8576791296bbe12d261a52d (mode 644)
--- /dev/null
+++ ex1-35.scm
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
+(define (close-enough? x y)
+ (< (abs (- x y)) 0.001))
+
+(define (half-interval-method f a b)
+ (let ((a-value (f a))
+ (b-value (f b)))
+ (cond ((and (negative? a-value) (positive? b-value))
+ (search f a b))
+ ((and (negative? b-value) (positive? a-value))
+ (search f b a))
+ (else
+ (error "Values are not of opposite sign" a b)))))
+(define tolerance 0.00001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(fixed-point (lambda (y) (+ (sin y) (cos y)))
+ 1.0)
+
+(define (sqrt x)
+ (fixed-point (lambda (y) (average y (/ x y)))
+ 1.0))
+
+(define (average x y)
+ (/ (+ x y) 2))
+
+(define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+ 1.0))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
blob - /dev/null
blob + cf922fe928abfc632d3128b02a7cba490778e0ef (mode 644)
--- /dev/null
+++ ex1-35.scm~
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
blob - /dev/null
blob + 7ebd215ce1359ff0e0cbba33ebb65284cf2cc56b (mode 644)
--- /dev/null
+++ ex1-36.scm
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
+(define (close-enough? x y)
+ (< (abs (- x y)) 0.001))
+
+(define (half-interval-method f a b)
+ (let ((a-value (f a))
+ (b-value (f b)))
+ (cond ((and (negative? a-value) (positive? b-value))
+ (search f a b))
+ ((and (negative? b-value) (positive? a-value))
+ (search f b a))
+ (else
+ (error "Values are not of opposite sign" a b)))))
+(define tolerance 0.00001)
+
+;; Exercise 1.36. Modify fixed-point so that it prints the sequence of approximations it generates, using the newline and display primitives shown in exercise 1.22. Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (display guess)
+ (newline)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ (begin (display next)
+ next)
+ (try next))))
+ (newline)
+ (try first-guess))
+
+(fixed-point (lambda (y) (+ (sin y) (cos y)))
+ 1.0)
+
+(define (sqrt x)
+ (fixed-point (lambda (y) (average y (/ x y)))
+ 1.0))
+
+(define (average x y)
+ (/ (+ x y) 2))
+
+(define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+ 1.0))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+(newline)
+(newline)
+(display "Finding solution to x^x = 1000 without average damping:")
+(fixed-point (lambda (x) (/ (log 1000) (log x)))
+ 2.0)
+;; 35 iterations
+
+(newline)
+(display "Finding solution to x^x = 1000 with average damping:")
+(fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+ 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
blob - /dev/null
blob + 66b3fb497a0079f0b8576791296bbe12d261a52d (mode 644)
--- /dev/null
+++ ex1-36.scm~
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
+(define (close-enough? x y)
+ (< (abs (- x y)) 0.001))
+
+(define (half-interval-method f a b)
+ (let ((a-value (f a))
+ (b-value (f b)))
+ (cond ((and (negative? a-value) (positive? b-value))
+ (search f a b))
+ ((and (negative? b-value) (positive? a-value))
+ (search f b a))
+ (else
+ (error "Values are not of opposite sign" a b)))))
+(define tolerance 0.00001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(fixed-point (lambda (y) (+ (sin y) (cos y)))
+ 1.0)
+
+(define (sqrt x)
+ (fixed-point (lambda (y) (average y (/ x y)))
+ 1.0))
+
+(define (average x y)
+ (/ (+ x y) 2))
+
+(define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+ 1.0))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
blob - /dev/null
blob + 7223eb4a3b54a0fdd2361079edee081f1191bf63 (mode 644)
--- /dev/null
+++ ex1-37.lisp
+(defun cont-frac (n d k)
+ (labels (
+ (frac (i)
+ (/ (funcall n i)
+ (+ (funcall d i)
+ (if (= i k)
+ 0
+ (frac (1+ i)))))))
+ (frac 1)))
+
+(defun cont-frac-iter (n d k)
+ (labels (
+ (frac-iter (i result)
+ (if (= i 0)
+ result
+ (frac-iter
+ (1- i)
+ (/ (funcall n i)
+ (+ (funcall d i) result))))))
+ (frac-iter k 0)))
blob - /dev/null
blob + ec35417c12921263d227548fd3ce0b18cb763be6 (mode 644)
--- /dev/null
+++ ex1-37.lisp~
+(defvar tolerance 0.00001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (try (guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defun average (a b)
+ (/ (+ a b) 2))
+(defun dampen-sqrt (x)
+ (fixed-point
+ (lambda (y)
+ (average y (/ x y)))
+ 1.0))
+
+(fixed-point (lambda (x) (1+ (/1 x))) 1.0)
+
+(defvar tolerance 0.00001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (try (guess)
+ (format t "Trying ~F~%" guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defun average (a b)
+ (/ (+ a b) 2))
+(defun xx (x)
+ (/ (log 1000) (log x)))
+(defun dampen-xx (x)
+ (average x (xx x)))
+(print (fixed-point #'xx 2.0))
+(print (fixed-point #'dampen-xx 2.0))
+
blob - /dev/null
blob + e2e8083ca0e163e28d6a53b0119455dffd11fa9c (mode 644)
--- /dev/null
+++ ex1-37.scm
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
+(define (close-enough? x y)
+ (< (abs (- x y)) 0.001))
+
+(define (half-interval-method f a b)
+ (let ((a-value (f a))
+ (b-value (f b)))
+ (cond ((and (negative? a-value) (positive? b-value))
+ (search f a b))
+ ((and (negative? b-value) (positive? a-value))
+ (search f b a))
+ (else
+ (error "Values are not of opposite sign" a b)))))
+(define tolerance 0.00001)
+
+;; Exercise 1.36. Modify fixed-point so that it prints the sequence of approximations it generates, using the newline and display primitives shown in exercise 1.22. Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+;; (display guess)
+;; (newline)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+;; (begin (display next)
+;; next)
+ next
+ (try next))))
+;; (newline)
+ (try first-guess))
+
+;;(fixed-point (lambda (y) (+ (sin y) (cos y)))
+;; 1.0)
+
+(define (sqrt x)
+ (fixed-point (lambda (y) (average y (/ x y)))
+ 1.0))
+
+(define (average x y)
+ (/ (+ x y) 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+;; (define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+;; 1.0))
+
+;; (newline)
+;; (newline)
+;; (display "Finding solution to x^x = 1000 without average damping:")
+;; (fixed-point (lambda (x) (/ (log 1000) (log x)))
+;; 2.0)
+;; 35 iterations
+
+;; (newline)
+;; (display "Finding solution to x^x = 1000 with average damping:")
+;; (fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+;; 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
+
+;; Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating 1/golden-ratio using
+
+(define (cont-frac n d k)
+ (define (cont-frac-rec i)
+ (if (> i k)
+ 0
+ (/ (n i) (+ (d i) (cont-frac-rec (1+ i))))))
+ (cont-frac-rec 1))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 10)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 100)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 1000)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?
+
+;; k has to be somewhere between 10-100
+
+;; b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
+
+(define (cont-frac-iter n d k)
+ (define (iter i result)
+ (if (= i 0)
+ result
+ (iter (- i 1) (/ (n i) (+ (/ d i) result)))))
+ (iter k 0))
+
+(test-case (cont-frac-iter (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 10)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac-iter (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 100)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac-iter (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 1000)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
blob - /dev/null
blob + 6e8fa11eae398e2d0afd8f9c41cd12037fcd0f91 (mode 644)
--- /dev/null
+++ ex1-37.scm~
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
+(define (close-enough? x y)
+ (< (abs (- x y)) 0.001))
+
+(define (half-interval-method f a b)
+ (let ((a-value (f a))
+ (b-value (f b)))
+ (cond ((and (negative? a-value) (positive? b-value))
+ (search f a b))
+ ((and (negative? b-value) (positive? a-value))
+ (search f b a))
+ (else
+ (error "Values are not of opposite sign" a b)))))
+(define tolerance 0.00001)
+
+;; Exercise 1.36. Modify fixed-point so that it prints the sequence of approximations it generates, using the newline and display primitives shown in exercise 1.22. Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+;; (display guess)
+;; (newline)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+;; (begin (display next)
+;; next)
+ next
+ (try next))))
+;; (newline)
+ (try first-guess))
+
+;;(fixed-point (lambda (y) (+ (sin y) (cos y)))
+;; 1.0)
+
+(define (sqrt x)
+ (fixed-point (lambda (y) (average y (/ x y)))
+ 1.0))
+
+(define (average x y)
+ (/ (+ x y) 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+;; (define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+;; 1.0))
+
+;; (newline)
+;; (newline)
+;; (display "Finding solution to x^x = 1000 without average damping:")
+;; (fixed-point (lambda (x) (/ (log 1000) (log x)))
+;; 2.0)
+;; 35 iterations
+
+;; (newline)
+;; (display "Finding solution to x^x = 1000 with average damping:")
+;; (fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+;; 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
+
+;; Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating 1/golden-ratio using
+
+(define (cont-frac n d k)
+ (define (cont-frac-rec i)
+ (if (> i k)
+ 0
+ (/ (n i) (+ (d i) (cont-frac-rec (1+ i))))))
+ (cont-frac-rec 1))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 10)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 100)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 1000)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?
+
+;; k has to be somewhere between 10-100
+
+;; b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
blob - /dev/null
blob + 7358a18473fba6b72532106b8579dccdc601bbf1 (mode 644)
--- /dev/null
+++ ex1-38.lisp
+(defun cont-frac (n d k)
+ (labels (
+ (frac (i)
+ (/ (funcall n i)
+ (+ (funcall d i)
+ (if (= i k)
+ 0
+ (frac (1+ i)))))))
+ (frac 1)))
+
+(defun cont-frac-iter (n d k)
+ (labels (
+ (frac-iter (i result)
+ (if (= i 0)
+ result
+ (frac-iter
+ (1- i)
+ (/ (funcall n i)
+ (+ (funcall d i) result))))))
+ (frac-iter k 0)))
+
+(print
+ (cont-frac
+ (lambda (i) 1.0)
+ (lambda (i)
+ (let ((i+1 (1+ i)))
+ (if (= (rem i+1 3) 0)
+ (* 2.0 (/ i+1 3))
+ 1.0)))
+ 10))
blob - /dev/null
blob + 7223eb4a3b54a0fdd2361079edee081f1191bf63 (mode 644)
--- /dev/null
+++ ex1-38.lisp~
+(defun cont-frac (n d k)
+ (labels (
+ (frac (i)
+ (/ (funcall n i)
+ (+ (funcall d i)
+ (if (= i k)
+ 0
+ (frac (1+ i)))))))
+ (frac 1)))
+
+(defun cont-frac-iter (n d k)
+ (labels (
+ (frac-iter (i result)
+ (if (= i 0)
+ result
+ (frac-iter
+ (1- i)
+ (/ (funcall n i)
+ (+ (funcall d i) result))))))
+ (frac-iter k 0)))
blob - /dev/null
blob + cf404b921f1f631c2e06b66fe45f8e74ed380639 (mode 644)
--- /dev/null
+++ ex1-38.scm
+;; (define (search f neg-point pos-point)
+;; (let ((midpoint (average neg-point pos-point)))
+;; (if (close-enough? neg-point pos-point)
+;; midpoint
+;; (let ((test-value (f midpoint)))
+;; (cond ((positive? test-value)
+;; (search f neg-point midpoint))
+;; ((negative? test-value)
+;; (search f midpoint pos-point))
+;; (else midpoint))))))
+;; (define (close-enough? x y)
+;; (< (abs (- x y)) 0.001))
+
+;; (define (half-interval-method f a b)
+;; (let ((a-value (f a))
+;; (b-value (f b)))
+;; (cond ((and (negative? a-value) (positive? b-value))
+;; (search f a b))
+;; ((and (negative? b-value) (positive? a-value))
+;; (search f b a))
+;; (else
+;; (error "Values are not of opposite sign" a b)))))
+;; (define tolerance 0.00001)
+
+;; (define (fixed-point f first-guess)
+;; (define (close-enough? v1 v2)
+;; (< (abs (- v1 v2)) tolerance))
+;; (define (try guess)
+;; ;; (display guess)
+;; ;; (newline)
+;; (let ((next (f guess)))
+;; (if (close-enough? guess next)
+;; ;; (begin (display next)
+;; ;; next)
+;; next
+;; (try next))))
+;; ;; (newline)
+;; (try first-guess))
+
+;;(fixed-point (lambda (y) (+ (sin y) (cos y)))
+;; 1.0)
+
+;; (define (sqrt x)
+;; (fixed-point (lambda (y) (average y (/ x y)))
+;; 1.0))
+
+;; (define (average x y)
+;; (/ (+ x y) 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+;; (define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+;; 1.0))
+
+;; (newline)
+;; (newline)
+;; (display "Finding solution to x^x = 1000 without average damping:")
+;; (fixed-point (lambda (x) (/ (log 1000) (log x)))
+;; 2.0)
+;; 35 iterations
+
+;; (newline)
+;; (display "Finding solution to x^x = 1000 with average damping:")
+;; (fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+;; 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
+
+;; Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating 1/golden-ratio using
+
+;; (define (cont-frac n d k)
+;; (define (cont-frac-rec i)
+;; (if (> i k)
+;; 0
+;; (/ (n i) (+ (d i) (cont-frac-rec (1+ i))))))
+;; (cont-frac-rec 1))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 10)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 100)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 1000)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?
+
+;; k has to be somewhere between 10-100
+
+;; b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
+
+(define (cont-frac-iter n d k)
+ (define (iter i result)
+ (if (= i 0)
+ result
+ (iter (- i 1) (/ (n i) (+ (d i) result)))))
+ (iter k 0.0))
+
+;; (test-case (cont-frac-iter (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 1000)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (+ 2.0
+ (cont-frac-iter (lambda (i) 1)
+ (lambda (i) (if (= (remainder i 3) 2)
+ (* (/ (+ i 1) 3) 2)
+ 1))
+ 100))
+ 2.7182818284590452353602874)
blob - /dev/null
blob + e2e8083ca0e163e28d6a53b0119455dffd11fa9c (mode 644)
--- /dev/null
+++ ex1-38.scm~
+(define (search f neg-point pos-point)
+ (let ((midpoint (average neg-point pos-point)))
+ (if (close-enough? neg-point pos-point)
+ midpoint
+ (let ((test-value (f midpoint)))
+ (cond ((positive? test-value)
+ (search f neg-point midpoint))
+ ((negative? test-value)
+ (search f midpoint pos-point))
+ (else midpoint))))))
+(define (close-enough? x y)
+ (< (abs (- x y)) 0.001))
+
+(define (half-interval-method f a b)
+ (let ((a-value (f a))
+ (b-value (f b)))
+ (cond ((and (negative? a-value) (positive? b-value))
+ (search f a b))
+ ((and (negative? b-value) (positive? a-value))
+ (search f b a))
+ (else
+ (error "Values are not of opposite sign" a b)))))
+(define tolerance 0.00001)
+
+;; Exercise 1.36. Modify fixed-point so that it prints the sequence of approximations it generates, using the newline and display primitives shown in exercise 1.22. Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+;; (display guess)
+;; (newline)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+;; (begin (display next)
+;; next)
+ next
+ (try next))))
+;; (newline)
+ (try first-guess))
+
+;;(fixed-point (lambda (y) (+ (sin y) (cos y)))
+;; 1.0)
+
+(define (sqrt x)
+ (fixed-point (lambda (y) (average y (/ x y)))
+ 1.0))
+
+(define (average x y)
+ (/ (+ x y) 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+;; (define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+;; 1.0))
+
+;; (newline)
+;; (newline)
+;; (display "Finding solution to x^x = 1000 without average damping:")
+;; (fixed-point (lambda (x) (/ (log 1000) (log x)))
+;; 2.0)
+;; 35 iterations
+
+;; (newline)
+;; (display "Finding solution to x^x = 1000 with average damping:")
+;; (fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+;; 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
+
+;; Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating 1/golden-ratio using
+
+(define (cont-frac n d k)
+ (define (cont-frac-rec i)
+ (if (> i k)
+ 0
+ (/ (n i) (+ (d i) (cont-frac-rec (1+ i))))))
+ (cont-frac-rec 1))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 10)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 100)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 1000)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?
+
+;; k has to be somewhere between 10-100
+
+;; b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
+
+(define (cont-frac-iter n d k)
+ (define (iter i result)
+ (if (= i 0)
+ result
+ (iter (- i 1) (/ (n i) (+ (/ d i) result)))))
+ (iter k 0))
+
+(test-case (cont-frac-iter (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 10)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac-iter (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 100)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (cont-frac-iter (lambda (i) 1.0)
+ (lambda (i) 1.0)
+ 1000)
+ (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
blob - /dev/null
blob + 38125855630f30522854beadf0e0aba07bf3ccdf (mode 644)
--- /dev/null
+++ ex1-39.lisp
+(defun tan-cf (x k)
+ (labels ((tan-step (i)
+ (/ (if (= i 1)
+ x
+ (square x))
+ (- (1- (* i 2))
+ (if (= i k)
+ 0
+ (tan-step (1+ i)))))))
+ (tan-step 1)))
blob - /dev/null
blob + 4b16181231413245c54ee9a225eb004453463aa9 (mode 644)
--- /dev/null
+++ ex1-39.lisp~
+(defun tan-cf (x k)
+ (labels ((tan-step (i)
+ (/ (if (= i 1)
+ x
+ (s
blob - /dev/null
blob + 5a59e1c70c3246ae75b76af91300d555116831a6 (mode 644)
--- /dev/null
+++ ex1-39.scm
+;; (define (search f neg-point pos-point)
+;; (let ((midpoint (average neg-point pos-point)))
+;; (if (close-enough? neg-point pos-point)
+;; midpoint
+;; (let ((test-value (f midpoint)))
+;; (cond ((positive? test-value)
+;; (search f neg-point midpoint))
+;; ((negative? test-value)
+;; (search f midpoint pos-point))
+;; (else midpoint))))))
+;; (define (close-enough? x y)
+;; (< (abs (- x y)) 0.001))
+
+;; (define (half-interval-method f a b)
+;; (let ((a-value (f a))
+;; (b-value (f b)))
+;; (cond ((and (negative? a-value) (positive? b-value))
+;; (search f a b))
+;; ((and (negative? b-value) (positive? a-value))
+;; (search f b a))
+;; (else
+;; (error "Values are not of opposite sign" a b)))))
+;; (define tolerance 0.00001)
+
+;; (define (fixed-point f first-guess)
+;; (define (close-enough? v1 v2)
+;; (< (abs (- v1 v2)) tolerance))
+;; (define (try guess)
+;; ;; (display guess)
+;; ;; (newline)
+;; (let ((next (f guess)))
+;; (if (close-enough? guess next)
+;; ;; (begin (display next)
+;; ;; next)
+;; next
+;; (try next))))
+;; ;; (newline)
+;; (try first-guess))
+
+;;(fixed-point (lambda (y) (+ (sin y) (cos y)))
+;; 1.0)
+
+;; (define (sqrt x)
+;; (fixed-point (lambda (y) (average y (/ x y)))
+;; 1.0))
+
+;; (define (average x y)
+;; (/ (+ x y) 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+;; (define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+;; 1.0))
+
+;; (newline)
+;; (newline)
+;; (display "Finding solution to x^x = 1000 without average damping:")
+;; (fixed-point (lambda (x) (/ (log 1000) (log x)))
+;; 2.0)
+;; 35 iterations
+
+;; (newline)
+;; (display "Finding solution to x^x = 1000 with average damping:")
+;; (fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+;; 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
+
+;; Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating 1/golden-ratio using
+
+;; (define (cont-frac n d k)
+;; (define (cont-frac-rec i)
+;; (if (> i k)
+;; 0
+;; (/ (n i) (+ (d i) (cont-frac-rec (1+ i))))))
+;; (cont-frac-rec 1))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 10)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 100)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 1000)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?
+
+;; k has to be somewhere between 10-100
+
+;; b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
+
+(define (cont-frac-iter n d k)
+ (define (iter i result)
+ (if (= i 0)
+ result
+ (iter (- i 1) (/ (n i) (+ (d i) result)))))
+ (iter k 0.0))
+
+;; (test-case (cont-frac-iter (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 1000)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (+ 2.0
+ (cont-frac-iter (lambda (i) 1)
+ (lambda (i) (if (= (remainder i 3) 2)
+ (* (/ (+ i 1) 3) 2)
+ 1))
+ 100))
+ 2.7182818284590452353602874)
+
+(define (fast-expt b n)
+ (cond ((= n 0) 1)
+ ((even? n) (square (fast-expt b (/ n 2))))
+ (else (* b (fast-expt b (- n 1))))))
+(define (square x) (* x x))
+
+(define (tan-cf x k)
+ (cont-frac-iter (lambda (i)
+ (if (= i 1)
+ x
+ (- (square x))))
+ (lambda (i) (- (* 2 i) 1))
+ k))
+
+(test-case (tan-cf 3.5 1000) 0.37458564015)
+(test-case (tan-cf 1.6 1000) -34.2325327)
+(test-case (tan-cf 2.8 1000) -0.355529832)
+
blob - /dev/null
blob + cf404b921f1f631c2e06b66fe45f8e74ed380639 (mode 644)
--- /dev/null
+++ ex1-39.scm~
+;; (define (search f neg-point pos-point)
+;; (let ((midpoint (average neg-point pos-point)))
+;; (if (close-enough? neg-point pos-point)
+;; midpoint
+;; (let ((test-value (f midpoint)))
+;; (cond ((positive? test-value)
+;; (search f neg-point midpoint))
+;; ((negative? test-value)
+;; (search f midpoint pos-point))
+;; (else midpoint))))))
+;; (define (close-enough? x y)
+;; (< (abs (- x y)) 0.001))
+
+;; (define (half-interval-method f a b)
+;; (let ((a-value (f a))
+;; (b-value (f b)))
+;; (cond ((and (negative? a-value) (positive? b-value))
+;; (search f a b))
+;; ((and (negative? b-value) (positive? a-value))
+;; (search f b a))
+;; (else
+;; (error "Values are not of opposite sign" a b)))))
+;; (define tolerance 0.00001)
+
+;; (define (fixed-point f first-guess)
+;; (define (close-enough? v1 v2)
+;; (< (abs (- v1 v2)) tolerance))
+;; (define (try guess)
+;; ;; (display guess)
+;; ;; (newline)
+;; (let ((next (f guess)))
+;; (if (close-enough? guess next)
+;; ;; (begin (display next)
+;; ;; next)
+;; next
+;; (try next))))
+;; ;; (newline)
+;; (try first-guess))
+
+;;(fixed-point (lambda (y) (+ (sin y) (cos y)))
+;; 1.0)
+
+;; (define (sqrt x)
+;; (fixed-point (lambda (y) (average y (/ x y)))
+;; 1.0))
+
+;; (define (average x y)
+;; (/ (+ x y) 2))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case golden-ratio (/ (+ 1.0 (sqrt 5.0)) 2.0))
+
+;; Then find a solution to x^x = 1000 by finding a fixed point of x-->log(1000)/log(x). (Use Scheme's primitive log procedure, which computes natural logarithms.) Compare the number of steps this takes with and without average damping. (Note that you cannot start fixed-point with a guess of 1, as this would cause division by log(1) = 0.)
+
+;; (define golden-ratio (fixed-point (lambda (x) (+ 1 (/ 1 x)))
+;; 1.0))
+
+;; (newline)
+;; (newline)
+;; (display "Finding solution to x^x = 1000 without average damping:")
+;; (fixed-point (lambda (x) (/ (log 1000) (log x)))
+;; 2.0)
+;; 35 iterations
+
+;; (newline)
+;; (display "Finding solution to x^x = 1000 with average damping:")
+;; (fixed-point (lambda (x) (average x (/ (log 1000) (log x))))
+;; 2.0)
+;; 10 iterations
+
+;; Average damping helps it converge much faster!
+
+;; Suppose that n and d are procedures of one argument (the term index i) that return the Ni and Di of the terms of the continued fraction. Define a procedure cont-frac such that evaluating (cont-frac n d k) computes the value of the k-term finite continued fraction. Check your procedure by approximating 1/golden-ratio using
+
+;; (define (cont-frac n d k)
+;; (define (cont-frac-rec i)
+;; (if (> i k)
+;; 0
+;; (/ (n i) (+ (d i) (cont-frac-rec (1+ i))))))
+;; (cont-frac-rec 1))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 10)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 100)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; (test-case (cont-frac (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 1000)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+;; for successive values of k. How large must you make k in order to get an approximation that is accurate to 4 decimal places?
+
+;; k has to be somewhere between 10-100
+
+;; b. If your cont-frac procedure generates a recursive process, write one that generates an iterative process. If it generates an iterative process, write one that generates a recursive process.
+
+(define (cont-frac-iter n d k)
+ (define (iter i result)
+ (if (= i 0)
+ result
+ (iter (- i 1) (/ (n i) (+ (d i) result)))))
+ (iter k 0.0))
+
+;; (test-case (cont-frac-iter (lambda (i) 1.0)
+;; (lambda (i) 1.0)
+;; 1000)
+;; (/ 1.0 (/ (+ 1.0 (sqrt 5)) 2.0)))
+
+(test-case (+ 2.0
+ (cont-frac-iter (lambda (i) 1)
+ (lambda (i) (if (= (remainder i 3) 2)
+ (* (/ (+ i 1) 3) 2)
+ 1))
+ 100))
+ 2.7182818284590452353602874)
blob - /dev/null
blob + a1f409fc061ad62acdd8587a99f3cc1f4549f662 (mode 644)
--- /dev/null
+++ ex1-4.scm
+(define (a-plus-abs-b a b)
+ ((if (> b 0) + -) a b))
\ No newline at end of file
blob - /dev/null
blob + ce21fed2cfd23c4802173768d0405c9701405b8d (mode 644)
--- /dev/null
+++ ex1-40.lisp
+(defvar *tolerance* 0.0001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) *tolerance*))
+ (try (guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defvar *dx* 0.00001)
+(defun deriv (g)
+ (lambda (x)
+ (/ (- (funcall g (+ x *dx*))
+ (funcall g x))
+ *dx*)))
+(defun newton-transform (g)
+ (lambda (x)
+ (- x (/ (funcall g x)
+ (funcall (deriv g) x)))))
+(defun newtons-method (g guess)
+ (fixed-point (newton-transform g) guess))
+
+(defun cubic (a b c)
+ (lambda (x)
+ (+ (cube x)
+ (* a (square x))
+ (* b x)
+ c)))
blob - /dev/null
blob + 8850ce7e945d0e7edf6f33966264e8cdafc617a9 (mode 644)
--- /dev/null
+++ ex1-40.lisp~
+(defvar *tolerance* 0.0001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) *tolerance*))
+ (try (guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defvar *dx* 0.00001)
+(defun deriv (g)
+ (lambda (x)
+ (/ (- (funcall g (+ x *dx*))
+ (funcall g x))
+ *dx*)))
+(defun newton-transform (g)
+ (lambda (x)
+ (- x (/ (funcall g x)
+ (funcall (deriv g) x)))))
blob - /dev/null
blob + e58f4a50e59c2d7ae83155648d4382b5d214c5c4 (mode 644)
--- /dev/null
+++ ex1-40.scm
+(define tolerance 0.00001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(define (average-damp f)
+ (lambda (x) (average x (f x))))
+(define (sqrt x)
+ (fixed-point (average-damp (lambda (y) (/ x y)))
+ 1.0))
+(define (cube-root x)
+ (fixed-point (average-damp (lambda (y) (/ x (square y))))
+ 1.0))
+(define (deriv g)
+ (lambda (x)
+ (/ (- (g (+ x dx)) (g x))
+ dx)))
+(define dx 0.00001)
+(define (newton-transform g)
+ (lambda (x)
+ (- x (/ (g x) ((deriv g) x)))))
+(define (newtons-method g guess)
+ (fixed-point (newton-transform g) guess))
+(define (sqrt x)
+ (newtons-method (lambda (y) (- (square y) x))
+ 1.0))
+(define (fixed-point-of-transform g transform guess)
+ (fixed-point (transform g) guess))
+(define (sqrt x)
+ (fixed-point-of-transform (lambda (y) (/ x y))
+ average-damp
+ 1.0))
+(define (sqrt x)
+ (fixed-point-of-transform (lambda (y) (- (square y) x))
+ newton-transform
+ 1.0))
+(define (cubic a b c)
+ (define (cube x) (* x x x))
+ (define (square x) (* x x))
+ (lambda (x)
+ (+ (cube x)
+ (* a (square x))
+ (* b x)
+ c)))
+
+(test-case (newtons-method (cubic 5 2 3) 1.0) -4.710623963172891)
+
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 432bde021c6c855155a7953ed02eb5373b38f95a (mode 644)
--- /dev/null
+++ ex1-41.scm
+(define (double p)
+ (lambda (x)
+ (p (p x))))
+
+;; What value is returned by
+
+;; (((double (double double)) inc) 5)
+nn
+(((double (double double)) inc) 5)
+(((double (lambda (x)
+ (double (double x)))) inc) 5)
+(((lambda (y)
+ ((lambda (x)
+ (double (double x)))
+ ((lambda (x)
+ (double (double x))) y))) inc) 5)
+(((lambda (y)
+ ((lambda (x)
+ (double (double x)))
+ ((lambda (x)
+ (double (double x))) y))) inc) 5)
+(((lambda (x)
+ (double (double x)))
+ ((lambda (x)
+ (double (double x))) inc)) 5)
+(((lambda (x)
+ (double (double x)))
+ ((double (double inc)))) 5)
+(((lambda (x)
+ (double (double x)))
+ ((double (double inc)))) 5)
+(((lambda (x)
+ (double (double x)))
+ ((double (lambda (x)
+ (inc (inc x)))))) 5)
+(((lambda (x)
+ (double (double x)))
+ ((double (lambda (x)
+ (inc (inc x)))))) 5)
+(((lambda (x)
+ (double (double x)))
+ ((double (lambda (x)
+ (inc (inc x)))))) 5)
+
+;; Suppose we defined the procedure below as dd
+;;(lambda (x)
+;; (double (double x)))
+(((lambda (x)
+ (dd (dd x))) inc) 5)
+
+(((dd (dd inc))) 5)
+(((dd (double (double inc)))) 5)
+(((dd (double (lambda (x)
+ (inc (inc x)))))) 5)
+(((dd ((lambda (x)
+ (inc (inc x)))
+ ((lambda (x)
+ (inc (inc x))) x)))) 5)
+((((double (double ((lambda (x)
+ (inc (inc x)))
+ ((lambda (x)
+ (inc (inc x))) x)))))) 5)
blob - /dev/null
blob + f83c55b56c70f92a14b9bd341f441460e22407ae (mode 644)
--- /dev/null
+++ ex1-41.scm~
+(define (double procedure)
+ (lambda (x)
+ (procedure (procedure (x)))))
blob - /dev/null
blob + c574b975b9b2eecaa8237f762c532bdcb2c00464 (mode 644)
--- /dev/null
+++ ex1-42.lisp
+(defun compose (f g)
+ (lambda (x)
+ (funcall f (funcall g x))))
blob - /dev/null
blob + eae85f45a07e2b211b43bea30c4714232aa8462b (mode 644)
--- /dev/null
+++ ex1-42.scm
+(define (compose f g)
+ (lambda (x)
+ (f (g x))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (square x) (* x x))
+(define (inc x) (1+ x))
+(test-case ((compose square inc) 6) 49)
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 84f64d2a20d961eb2df5845bdbd7fc75648fe724 (mode 644)
--- /dev/null
+++ ex1-43.lisp
+(defun repeated (f n)
+ (if (= n 0)
+ (lambda (x) x)
+ (compose f (repeated f (1- n)))))
blob - /dev/null
blob + c78b1c3279baf11e473f4fdabba3b226a62ac708 (mode 644)
--- /dev/null
+++ ex1-43.scm
+(define tolerance 0.00001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(define (average x y)
+ (/ (+ x y) 2.0))
+(define (average-damp f)
+ (lambda (x) (average x (f x))))
+(define (fixed-point-of-transform g transform guess)
+ (fixed-point (transform g) guess))
+(define (sqrt x)
+ (fixed-point-of-transform (lambda (y) (/ x y))
+ average-damp
+ 1.0))
+(define (cube-root x)
+ (fixed-point-of-transform (lambda (y) (/ x (square y)))
+ average-damp
+ 1.0))
+
+(define (compose f g)
+ (lambda (x)
+ (f (g x))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (square x) (* x x))
+(define (inc x) (1+ x))
+;; (test-case ((compose square inc) 6) 49)
+
+(define (repeated f n)
+ (if (= n 0)
+ (lambda (x) x)
+ (compose f (repeated f (- n 1)))))
+
+;; (test-case ((repeated square 2) 5) 625)
+(test-case (cube-root 5) 1.70997594668)
+
+
+;; Exercise 1.44. The idea of smoothing a function is an important concept in signal processing. If f is a function and dx is some small number, then the smoothed version of f is the function whose value at a point x is the average of f(x - dx), f(x), and f(x + dx). Write a procedure smooth that takes as input a procedure that computes f and returns a procedure that computes the smoothed f. It is sometimes valuable to repeatedly smooth a function (that is, smooth the smoothed function, and so on) to obtained the n-fold smoothed function. Show how to generate the n-fold smoothed function of any given function using smooth and repeated from exercise 1.43.
+
+(define dx 0.01)
+
+(define (smooth f)
+ (lambda (x)
+ (/ (+ (f x)
+ (f (+ x dx))
+ (f (- x dx)))
+ 3.0)))
+(define (n-fold-smooth f n)
+ ((repeated smooth n) f))
blob - /dev/null
blob + c78b1c3279baf11e473f4fdabba3b226a62ac708 (mode 644)
--- /dev/null
+++ ex1-43.scm~
+(define tolerance 0.00001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(define (average x y)
+ (/ (+ x y) 2.0))
+(define (average-damp f)
+ (lambda (x) (average x (f x))))
+(define (fixed-point-of-transform g transform guess)
+ (fixed-point (transform g) guess))
+(define (sqrt x)
+ (fixed-point-of-transform (lambda (y) (/ x y))
+ average-damp
+ 1.0))
+(define (cube-root x)
+ (fixed-point-of-transform (lambda (y) (/ x (square y)))
+ average-damp
+ 1.0))
+
+(define (compose f g)
+ (lambda (x)
+ (f (g x))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (square x) (* x x))
+(define (inc x) (1+ x))
+;; (test-case ((compose square inc) 6) 49)
+
+(define (repeated f n)
+ (if (= n 0)
+ (lambda (x) x)
+ (compose f (repeated f (- n 1)))))
+
+;; (test-case ((repeated square 2) 5) 625)
+(test-case (cube-root 5) 1.70997594668)
+
+
+;; Exercise 1.44. The idea of smoothing a function is an important concept in signal processing. If f is a function and dx is some small number, then the smoothed version of f is the function whose value at a point x is the average of f(x - dx), f(x), and f(x + dx). Write a procedure smooth that takes as input a procedure that computes f and returns a procedure that computes the smoothed f. It is sometimes valuable to repeatedly smooth a function (that is, smooth the smoothed function, and so on) to obtained the n-fold smoothed function. Show how to generate the n-fold smoothed function of any given function using smooth and repeated from exercise 1.43.
+
+(define dx 0.01)
+
+(define (smooth f)
+ (lambda (x)
+ (/ (+ (f x)
+ (f (+ x dx))
+ (f (- x dx)))
+ 3.0)))
+(define (n-fold-smooth f n)
+ ((repeated smooth n) f))
blob - /dev/null
blob + 31f64f7481a7bd09a019fb2af7737f8d22fb43d8 (mode 644)
--- /dev/null
+++ ex1-44.lisp
+(defvar *dx* 0.00001)
+(defun smooth (f)
+ (lambda (x)
+ (/ (+ (funcall f (- x *db*))
+ (funcall f x)
+ (funcall f (+ x *dx*)))
+ 3)))
+(defun n-fold-smooth (f n)
+ (funcall (repeated #'smooth n) f))
blob - /dev/null
blob + c78b1c3279baf11e473f4fdabba3b226a62ac708 (mode 644)
--- /dev/null
+++ ex1-44.scm
+(define tolerance 0.00001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(define (average x y)
+ (/ (+ x y) 2.0))
+(define (average-damp f)
+ (lambda (x) (average x (f x))))
+(define (fixed-point-of-transform g transform guess)
+ (fixed-point (transform g) guess))
+(define (sqrt x)
+ (fixed-point-of-transform (lambda (y) (/ x y))
+ average-damp
+ 1.0))
+(define (cube-root x)
+ (fixed-point-of-transform (lambda (y) (/ x (square y)))
+ average-damp
+ 1.0))
+
+(define (compose f g)
+ (lambda (x)
+ (f (g x))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (square x) (* x x))
+(define (inc x) (1+ x))
+;; (test-case ((compose square inc) 6) 49)
+
+(define (repeated f n)
+ (if (= n 0)
+ (lambda (x) x)
+ (compose f (repeated f (- n 1)))))
+
+;; (test-case ((repeated square 2) 5) 625)
+(test-case (cube-root 5) 1.70997594668)
+
+
+;; Exercise 1.44. The idea of smoothing a function is an important concept in signal processing. If f is a function and dx is some small number, then the smoothed version of f is the function whose value at a point x is the average of f(x - dx), f(x), and f(x + dx). Write a procedure smooth that takes as input a procedure that computes f and returns a procedure that computes the smoothed f. It is sometimes valuable to repeatedly smooth a function (that is, smooth the smoothed function, and so on) to obtained the n-fold smoothed function. Show how to generate the n-fold smoothed function of any given function using smooth and repeated from exercise 1.43.
+
+(define dx 0.01)
+
+(define (smooth f)
+ (lambda (x)
+ (/ (+ (f x)
+ (f (+ x dx))
+ (f (- x dx)))
+ 3.0)))
+(define (n-fold-smooth f n)
+ ((repeated smooth n) f))
blob - /dev/null
blob + 62c895539eec4b4526ac88c9a8a0e5293128beb5 (mode 644)
--- /dev/null
+++ ex1-45.lisp
+(defvar *tolerance* 0.00001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) *tolerance*))
+ (try (guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defun average (a b)
+ (/ (+ a b) 2))
+
+(defun dampen-sqrt (x)
+ (fixed-point
+ (lambda (y)
+ (average y (/ x y)))
+ 1.0))
+
+(defun dampen-root (x n)
+ (fixed-point
+ (lambda (y)
+ (average y (/ x (expt y (1- n)))))
+ 1.0))
+(defun repeated-dampen-root (x nroot nrepeat)
+ (fixed-point-of-transform
+ (lambda (y) (average y (/ x (expt y (1- nroot)))))
+ (repeated #'average-damp nrepeat)
+ 1.0))
+(print (repeated-dampen-root 2 4 2))
blob - /dev/null
blob + 8cb3ff3f77925e684642410914fea467a9de5ab8 (mode 644)
--- /dev/null
+++ ex1-45.lisp~
+(defvar *tolerance* 0.00001)
+(defun fixed-point (f first-guess)
+ (labels (
+ (close-enough? (v1 v2)
+ (< (abs (- v1 v2)) *tolerance*))
+ (try (guess)
+ (let ((next (funcall f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next)))))
+ (try first-guess)))
+(defun average (a b)
+ (/ (+ a b) 2))
+
+(defun dampen-sqrt (x)
+ (fixed-point
+ (lambda (y)
+ (average y (/ x y)))
+ 1.0))
+
+(defun dampen-root (x n)
+ (fixed-point
+ (lambda (y)
+ (average y (/ x (expt y (1- n)))))
+ 1.0))
blob - /dev/null
blob + 99e0938288f6fbc1965db100378bfc68ae345df7 (mode 644)
--- /dev/null
+++ ex1-45.scm
+;; (define tolerance 0.0000001)
+;; (define (fixed-point f first-guess)
+;; (define (close-enough? v1 v2)
+;; (< (abs (- v1 v2)) tolerance))
+;; (define (try guess)
+;; (let ((next (f guess)))
+;; (if (close-enough? guess next)
+;; next
+;; (try next))))
+;; (try first-guess))
+
+(define (average x y)
+ (/ (+ x y) 2.0))
+;; (define (average-damp f)
+;; (lambda (x) (average x (f x))))
+;; (define (fixed-point-of-transform g transform guess)
+;; (fixed-point (transform g) guess))
+;; (define (sqrt x)
+;; (fixed-point-of-transform (lambda (y) (/ x y))
+;; average-damp
+;; 1.0))
+;; (define (cube-root x)
+;; (fixed-point-of-transform (lambda (y) (/ x (square y)))
+;; average-damp
+;; 1.0))
+
+;; (define (compose f g)
+;; (lambda (x)
+;; (f (g x))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (square x) (* x x))
+;; (define (inc x) (1+ x))
+;; (test-case ((compose square inc) 6) 49)
+
+;; (define (repeated f n)
+;; (if (= n 0)
+;; (lambda (x) x)
+;; (compose f (repeated f (- n 1)))))
+
+;; (test-case ((repeated square 2) 5) 625)
+;; (test-case (cube-root 5) 1.70997594668)
+
+
+;; Exercise 1.44. The idea of smoothing a function is an important concept in signal processing. If f is a function and dx is some small number, then the smoothed version of f is the function whose value at a point x is the average of f(x - dx), f(x), and f(x + dx). Write a procedure smooth that takes as input a procedure that computes f and returns a procedure that computes the smoothed f. It is sometimes valuable to repeatedly smooth a function (that is, smooth the smoothed function, and so on) to obtained the n-fold smoothed function. Show how to generate the n-fold smoothed function of any given function using smooth and repeated from exercise 1.43.
+
+;; (define dx 0.01)
+
+;; (define (smooth f)
+;; (lambda (x)
+;; (/ (+ (f x)
+;; (f (+ x dx))
+;; (f (- x dx)))
+;; 3.0)))
+;; (define (n-fold-smooth f n)
+;; ((repeated smooth n) f))
+
+;; Exercise 1.45. We saw in section 1.3.3 that attempting to compute square roots by naively finding a fixed point of y x/y does not converge, and that this can be fixed by average damping. The same method works for finding cube roots as fixed points of the average-damped y x/y2. Unfortunately, the process does not work for fourth roots -- a single average damp is not enough to make a fixed-point search for y x/y3 converge. On the other hand, if we average damp twice (i.e., use the average damp of the average damp of y x/y3) the fixed-point search does converge. Do some experiments to determine how many average damps are required to compute nth roots as a fixed-point search based upon repeated average damping of y x/yn-1. Use this to implement a simple procedure for computing nth roots using fixed-point, average-damp, and the repeated procedure of exercise 1.43. Assume that any arithmetic operations you need are available as primitives.
+
+;; (define (fast-expt b n)
+;; (cond ((= n 0) 1)
+;; ((even? n) (square (fast-expt b (/ n 2))))
+;; (else (* b (fast-expt b (- n 1))))))
+
+
+;; (define (quartic-root x)
+;; (fixed-point-of-transform (lambda (y) (/ x (cube y)))
+;; (repeated average-damp 2)
+;; 1.0))
+;; (define (nth-root-test x n d)
+;; (fixed-point-of-transform (lambda (y) (/ x (expt y (- n 1))))
+;; (repeated average-damp d)
+;; 1.0))
+
+;; (test-case (nth-root-test 19 1 0) 19)
+;; (test-case (nth-root-test 19 2 1) 4.35889894)
+;; (test-case (nth-root-test 19 3 1) 2.66840165)
+;; (test-case (nth-root-test 19 4 2) 2.08779763)
+;; (test-case (nth-root-test 19 5 2) 1.80198313)
+;; (test-case (nth-root-test 19 6 2) 1.6335243)
+;; (test-case (nth-root-test 199 7 2) 2.13013723)
+;; (test-case (nth-root-test 199 8 3) 1.93801277)
+;; (test-case (nth-root-test 199 9 3) 1.80064508)
+;; (test-case (nth-root-test 199 10 3) 1.69779522)
+;; (test-case (nth-root-test 19999 11 3) 2.46037187)
+;; (test-case (nth-root-test 19999 12 3) 2.28253453)
+;; (test-case (nth-root-test 19999 13 3) 2.14213477)
+;; (test-case (nth-root-test 19999 14 3) 2.02868621)
+;; (test-case (nth-root-test 19999 15 3) 1.93523578)
+;; (test-case (nth-root-test 1999999 16 4) 2.47636331)
+;; (test-case (nth-root-test 1999999 17 4) 2.34773357)
+
+
+;; At first, my conclusion: average damp = sqrt(n), rounded down -- EXCEPT for 8...why is that?
+;; Maybe: 2^average damp = n
+
+;; (define (nth-root x n)
+;; (fixed-point-of-transform (lambda (y) (/ x (expt y (- n 1))))
+;; (repeated average-damp (truncate (/ (log n) (log 2))))
+;; 1.0))
+
+;; (test-case (nth-root 19 1) 19)
+;; (test-case (nth-root 19 2) 4.35889894)
+;; (test-case (nth-root 19 3) 2.66840165)
+;; (test-case (nth-root 19 4) 2.08779763)
+;; (test-case (nth-root 19 5) 1.80198313)
+;; (test-case (nth-root 19 6) 1.6335243)
+;; (test-case (nth-root 199 7) 2.13013723)
+;; (test-case (nth-root 199 8) 1.93801277)
+;; (test-case (nth-root 199 9) 1.80064508)
+;; (test-case (nth-root 199 10) 1.69779522)
+;; (test-case (nth-root 19999 11) 2.46037187)
+;; (test-case (nth-root 19999 12) 2.28253453)
+;; (test-case (nth-root 19999 13) 2.14213477)
+;; (test-case (nth-root 19999 14) 2.02868621)
+;; (test-case (nth-root 19999 15) 1.93523578)
+;; (test-case (nth-root 1999999 16) 2.47636331)
+;; (test-case (nth-root 1999999 17) 2.34773357)
+
+;; Exercise 1.46. Several of the numerical methods described in this chapter are instances of an extremely general computational strategy known as iterative improvement. Iterative improvement says that, to compute something, we start with an initial guess for the answer, test if the guess is good enough, and otherwise improve the guess and continue the process using the improved guess as the new guess. Write a procedure iterative-improve that takes two procedures as arguments: a method for telling whether a guess is good enough and a method for improving a guess. Iterative-improve should return as its value a procedure that takes a guess as argument and keeps improving the guess until it is good enough. Rewrite the sqrt procedure of section 1.1.7 and the fixed-point procedure of section 1.3.3 in terms of iterative-improve.
+
+(define (iterative-improve good-enough? improve)
+ (define (iter guess)
+ (if (good-enough? guess)
+ guess
+ (iter (improve guess))))
+ iter)
+
+(define (sqrt guess x)
+ ((iterative-improve (lambda (guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (lambda (guess)
+ (average guess (/ x guess)))) guess))
+
+
+(test-case (sqrt 2.2 5) 2.23606798)
+
+(define (fixed-point f guess)
+ (let ((tolerance 0.0000001))
+ ((iterative-improve (lambda (guess)
+ (< (abs (- guess (f guess))) tolerance))
+ (lambda (guess)
+ (f guess))) guess)))
+
+(test-case (fixed-point (lambda (x)
+ (cos x))
+ 1)
+ 0.73956720221)
+
+
blob - /dev/null
blob + 967fe8e0ab02e44187d9ad1d041398d2ee353cad (mode 644)
--- /dev/null
+++ ex1-45.scm~
+(define tolerance 0.0000001)
+(define (fixed-point f first-guess)
+ (define (close-enough? v1 v2)
+ (< (abs (- v1 v2)) tolerance))
+ (define (try guess)
+ (let ((next (f guess)))
+ (if (close-enough? guess next)
+ next
+ (try next))))
+ (try first-guess))
+
+(define (average x y)
+ (/ (+ x y) 2.0))
+(define (average-damp f)
+ (lambda (x) (average x (f x))))
+(define (fixed-point-of-transform g transform guess)
+ (fixed-point (transform g) guess))
+(define (sqrt x)
+ (fixed-point-of-transform (lambda (y) (/ x y))
+ average-damp
+ 1.0))
+(define (cube-root x)
+ (fixed-point-of-transform (lambda (y) (/ x (square y)))
+ average-damp
+ 1.0))
+
+(define (compose f g)
+ (lambda (x)
+ (f (g x))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (square x) (* x x))
+(define (inc x) (1+ x))
+;; (test-case ((compose square inc) 6) 49)
+
+(define (repeated f n)
+ (if (= n 0)
+ (lambda (x) x)
+ (compose f (repeated f (- n 1)))))
+
+;; (test-case ((repeated square 2) 5) 625)
+;; (test-case (cube-root 5) 1.70997594668)
+
+
+;; Exercise 1.44. The idea of smoothing a function is an important concept in signal processing. If f is a function and dx is some small number, then the smoothed version of f is the function whose value at a point x is the average of f(x - dx), f(x), and f(x + dx). Write a procedure smooth that takes as input a procedure that computes f and returns a procedure that computes the smoothed f. It is sometimes valuable to repeatedly smooth a function (that is, smooth the smoothed function, and so on) to obtained the n-fold smoothed function. Show how to generate the n-fold smoothed function of any given function using smooth and repeated from exercise 1.43.
+
+(define dx 0.01)
+
+(define (smooth f)
+ (lambda (x)
+ (/ (+ (f x)
+ (f (+ x dx))
+ (f (- x dx)))
+ 3.0)))
+(define (n-fold-smooth f n)
+ ((repeated smooth n) f))
+
+;; Exercise 1.45. We saw in section 1.3.3 that attempting to compute square roots by naively finding a fixed point of y x/y does not converge, and that this can be fixed by average damping. The same method works for finding cube roots as fixed points of the average-damped y x/y2. Unfortunately, the process does not work for fourth roots -- a single average damp is not enough to make a fixed-point search for y x/y3 converge. On the other hand, if we average damp twice (i.e., use the average damp of the average damp of y x/y3) the fixed-point search does converge. Do some experiments to determine how many average damps are required to compute nth roots as a fixed-point search based upon repeated average damping of y x/yn-1. Use this to implement a simple procedure for computing nth roots using fixed-point, average-damp, and the repeated procedure of exercise 1.43. Assume that any arithmetic operations you need are available as primitives.
+
+(define (fast-expt b n)
+ (cond ((= n 0) 1)
+ ((even? n) (square (fast-expt b (/ n 2))))
+ (else (* b (fast-expt b (- n 1))))))
+
+
+(define (quartic-root x)
+ (fixed-point-of-transform (lambda (y) (/ x (cube y)))
+ (repeated average-damp 2)
+ 1.0))
+(define (nth-root-test x n d)
+ (fixed-point-of-transform (lambda (y) (/ x (expt y (- n 1))))
+ (repeated average-damp d)
+ 1.0))
+
+;; (test-case (nth-root-test 19 1 0) 19)
+;; (test-case (nth-root-test 19 2 1) 4.35889894)
+;; (test-case (nth-root-test 19 3 1) 2.66840165)
+;; (test-case (nth-root-test 19 4 2) 2.08779763)
+;; (test-case (nth-root-test 19 5 2) 1.80198313)
+;; (test-case (nth-root-test 19 6 2) 1.6335243)
+;; (test-case (nth-root-test 199 7 2) 2.13013723)
+;; (test-case (nth-root-test 199 8 3) 1.93801277)
+;; (test-case (nth-root-test 199 9 3) 1.80064508)
+;; (test-case (nth-root-test 199 10 3) 1.69779522)
+;; (test-case (nth-root-test 19999 11 3) 2.46037187)
+;; (test-case (nth-root-test 19999 12 3) 2.28253453)
+;; (test-case (nth-root-test 19999 13 3) 2.14213477)
+;; (test-case (nth-root-test 19999 14 3) 2.02868621)
+;; (test-case (nth-root-test 19999 15 3) 1.93523578)
+;; (test-case (nth-root-test 1999999 16 4) 2.47636331)
+;; (test-case (nth-root-test 1999999 17 4) 2.34773357)
+
+
+;; At first, my conclusion: average damp = sqrt(n), rounded down -- EXCEPT for 8...why is that?
+;; Maybe: 2^average damp = n
+
+(define (nth-root x n)
+ (fixed-point-of-transform (lambda (y) (/ x (expt y (- n 1))))
+ (repeated average-damp (truncate (/ (log n) (log 2))))
+ 1.0))
+
+(test-case (nth-root 19 1) 19)
+(test-case (nth-root 19 2) 4.35889894)
+(test-case (nth-root 19 3) 2.66840165)
+(test-case (nth-root 19 4) 2.08779763)
+(test-case (nth-root 19 5) 1.80198313)
+(test-case (nth-root 19 6) 1.6335243)
+(test-case (nth-root 199 7) 2.13013723)
+(test-case (nth-root 199 8) 1.93801277)
+(test-case (nth-root 199 9) 1.80064508)
+(test-case (nth-root 199 10) 1.69779522)
+(test-case (nth-root 19999 11) 2.46037187)
+(test-case (nth-root 19999 12) 2.28253453)
+(test-case (nth-root 19999 13) 2.14213477)
+(test-case (nth-root 19999 14) 2.02868621)
+(test-case (nth-root 19999 15) 1.93523578)
+(test-case (nth-root 1999999 16) 2.47636331)
+(test-case (nth-root 1999999 17) 2.34773357)
blob - /dev/null
blob + 47ef38cd6553257f2844d7a532fbbd0595e1653c (mode 644)
--- /dev/null
+++ ex1-46.lisp
+(defun iterative-improve (good-enough? improve)
+ (lambda (first-guess)
+ (labels (
+ (improve-iter (guess)
+ (let ((improved-guess (funcall improve guess)))
+ (if
blob - /dev/null
blob + f161311325a090286a57f052c1cc482fd9390258 (mode 644)
--- /dev/null
+++ ex1-46.lisp~
+(defun iterative-improve (good-enough? improve)
+ (lambda (first-guess)
+ (labels (
+ (improve-iter (guess)
+
blob - /dev/null
blob + e10c468f38b75cbeecff2c4c454ca55fe56276c1 (mode 644)
--- /dev/null
+++ ex1-5.scm
+(define (p) (p))
+(define (text x y)
+ (if (= x 0)
+ 0
+ y))
+(test 0 (p))
+
+Applicative order will go into an infinite loop when trying to evaluate the operand (p)
+Normal-order will evaluate it as:
+
+(if (= 0 0)
+ 0
+ (p))
+0
\ No newline at end of file
blob - /dev/null
blob + 1c19ac8553bb86c329e227990e6188ab229c690b (mode 644)
--- /dev/null
+++ ex1-6.scm
+(define (new-if predicate then-clause else-clause)
+ (cond (predicate then-clause)
+ (else else-clause)))
+(define (sqrt-iter guess x)
+ (new-if (good-enough? guess x)
+ guess
+ (sqrt-iter (improve guess x)
+ x)))
+According to the general evaluation rule, all sub-expressions must be evaluated (the scheme interpreter follow applicative-order evaluation). The problem is that for sqrt-iter is that the 3rd expression that it passes to new-if is recursive. So, the interpreter will attempt to evaluate the 3rd sub-expression an never terminate. It ends up getting stuck in an infinite recursion. The reason the if-special form must be provided is so that the else-clause is never evaluated if the predicate evaluates to true. The "short-circuit"-ing behavior is necessary to avoid infinite recursion.
\ No newline at end of file
blob - /dev/null
blob + a70fb695277315e866b25ed390871b9aea935e73 (mode 644)
--- /dev/null
+++ ex1-6.scm~
+(define (new-if predicate then-clause else-clause)
+ (cond (predicate then-clause)
+ (else else-clause)))
blob - /dev/null
blob + 83852b93b98b3a6d16d642eb5b77a84e13c70082 (mode 644)
--- /dev/null
+++ ex1-7.scm
+;; (define (sqrt x)
+;; (sqrt-iter 1.0 x))
+;; (define (sqrt-iter guess x)
+;; (if (good-enough? guess x)
+;; guess
+;; (sqrt-iter (improve guess x) x)))
+;; (define (good-enough? guess x)
+;; (< (abs (- (square guess) x)) 0.001))
+;; (define (square x) (* x x))
+;; (define (improve guess x)
+;; (average guess (/ x guess)))
+;; (define (average x y)
+;; (/ (+ x y) 2))
+
+;; (sqrt 0.001)
+;; 0.0316227766
+;; error is quite large
+;; for small numbers, the reason is simply because the sqrt is too close to the tolerance of 0.001
+
+;; (sqrt 1234567890123456789012345678901234567890)
+
+;; for large numbers, a number must be expressed as a float. A float is made up of a mantissa and exponent. As the exponent gets larger, the difference between each quantum of allowed floating point gets bigger and bigger. Unfortunately, this means that (improve guess x) might give the same result each time, even though (good-enough? guess x) keeps returning #f. So, with each iteration, the guess does not get any more accurate and hence the recursive process is never able to terminate. We end up with infinite recursion.
+
+(define (sqrt x)
+ (sqrt-iter 1.0 0.0 x))
+(define (sqrt-iter guess prev-guess x)
+ (if (good-enough? guess prev-guess)
+ guess
+ (sqrt-iter (improve guess x) guess x)))
+(define (good-enough? guess prev-guess)
+ (< (/ (abs (- guess prev-guess)) guess) 0.001))
+(define (square x) (* x x))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+
+(sqrt 0.001)
+;; 0.0316227766
+
+;; Much better for small numbers
blob - /dev/null
blob + fabb2c628e6c7719bf8fcfd04938939f76983aee (mode 644)
--- /dev/null
+++ ex1-7.scm~
+(define (sqrt x)
+ (sqrt-iter 1.0 x))
+(define (sqrt-iter guess x)
+ (if (good-enough? guess x)
+ guess
+ (sqrt-iter (improve guess x) x)))
\ No newline at end of file
blob - /dev/null
blob + dafa353696d0bbcbdca1edc6dc11581f9341304d (mode 644)
--- /dev/null
+++ ex1-7b.scm
+(define sqrt-iter (guess x)
+ (let ((improved-guess (improve guess x)))
+ (if (close-enough? guess improved-guess)
+ improved-guess
+ (sqrt-iter improved-guess x))))
+(define (close-enough? guess x)
+ (let ((ratio (/ a b)))
+ (and (< ratio 1.001) (> ratio 0.0999))))
+
+
+
+
\ No newline at end of file
blob - /dev/null
blob + 377f5190e36687a3f89ca1b6ebb87cfdb041e376 (mode 644)
--- /dev/null
+++ ex1-8.scm
+(define (cbrt x)
+ (cbrt-iter 1.0 x))
+
+(define (cbrt-iter guess x)
+ (if (good-enough? guess x)
+ guess
+ (cbrt-iter (improve guess x) x)))
+
+(define (good-enough? guess x)
+ (< (abs (- (cube guess) x)) 0.001))
+
+(define (improve guess x)
+ (/ (+ (/ x (square guess)) (* 2 guess)) 3))
+(define (square x) (* x x))
+(define (cube x) (* x x x))
+
+(cbrt 15)
+;; 2.46621207
+(cbrt 8)
+;; 2
+(cbrt 64)
+;; 4
\ No newline at end of file
blob - /dev/null
blob + 96ca7a654c450356ecd0ff440dd701e07efd627c (mode 644)
--- /dev/null
+++ ex1-8.scm~
+(define (cube guess x)
+ (if (good-enough? ...)
+ guess
+ (improve guess x)))
blob - /dev/null
blob + 49b46e1feddc8acd63413091068a81cbd4b3e8fe (mode 644)
--- /dev/null
+++ ex1-9.scm
+(define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+
+(define (factorial n)
+ (fact-iter 1 1 n))
+(define (fact-iter product counter max-count)
+ (if (> counter max-count)
+ product
+ (fact-iter (* product counter) (+ counter 1) max-count)))
+
+
+(define (+ a b)
+ (if ( = a 0)
+ b
+ (inc (+ (dec a) b))))
+
+;; This is a recursive process
+(+ 4 5)
+(inc (+ 3 5))
+(inc (inc (+ 2 5)))
+(inc (inc (inc (+ 1 5))))
+(inc (inc (inc (inc (+ 0 5)))))
+(inc (inc (inc (inc 5))))
+;; ...
+
+(define (+ a b)
+ (if (= a 0)
+ b
+ (+ (dec a) (inc b))))
+
+;; This is an iterative process
+(+ 4 5)
+(+ 3 6)
+(+ 2 7)
+(+ 1 8)
+(+ 0 9)
\ No newline at end of file
blob - /dev/null
blob + 16ea0d3c665879e2aae15b39444a446f4cf85c86 (mode 644)
--- /dev/null
+++ ex1-9.scm~
+(define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+
+(define (factorial n)
+ (fact-iter 1 1 n))
+(define (fact-iter product counter max-count)
+ (if (> counter max-count)
+ product
+ (fact-iter (* product counter) (+ counter 1) max-count)))
blob - /dev/null
blob + f699b6849a920fa8595566302a2745c59b73f198 (mode 644)
--- /dev/null
+++ ex2-1.lisp
+(defun make-rat (n d)
+ (labels ((make-rat-reduce (n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (cond ((and (< n 0) (< d 0))
+ (make-rat-reduce (- n) (- d)))
+ ((and (< d 0) (> n 0))
+ (make-rat-reduce (- n) (- d)))
+ (t (make-rat-reduce n d)))))
+(defun numer (x)
+ (car x))
+(defun denom (x)
+ (cdr x))
+
blob - /dev/null
blob + 502e2391c7380ce9e44e7cca4ffcddefc1aa06e1 (mode 644)
--- /dev/null
+++ ex2-1.scm
+(define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+(define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+(define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+(define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+(define (equal-rat? x y)
+ (= (* (numer x) (denom y))
+ (* (numer y) (denom x))))
+
+(define (print-rat x)
+ (newline)
+ (display (numer x))
+ (display "/")
+ (display (denom x)))
+
+
+(define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+;; (define (make-rat n d)
+;; (let ((g (gcd n d)))
+;; (cons (/ n g) (/ d g))))
+(define (numer x) (car x))
+(define (denom x) (cdr x))
+
+;; (define one-half (make-rat 1 2))
+;; (define one-third (make-rat 1 3))
+
+;; (print-rat one-half)
+;; (print-rat (make-rat 1 2))
+;; (print-rat (add-rat one-third one-third))
+;; (print-rat (make-rat 2 3))
+;; (print-rat (add-rat one-half one-third))
+;; (print-rat (make-rat 5 6))
+;; (print-rat (mul-rat one-half one-third))
+;; (print-rat (make-rat 1 6))
+;; (print-rat (add-rat one-third one-third))
+;; (print-rat (make-rat 2 3))
+
+;; Exercise 2.1. Define a better version of make-rat that handles both positive and negative arguments. Make-rat should normalize the sign so that if the rational number is positive, both the numerator and denominator are positive, and if the rational number is negative, only the numerator is negative.
+
+(define (make-rat n d)
+ (if (= d 0)
+ (error "Division by zero")
+ (let ((g-mag (abs (gcd n d)))
+ (n-mag (abs n))
+ (d-mag (abs d)))
+ (if (< (* n d) 0)
+ (cons (- (/ n-mag g-mag)) (/ d-mag g-mag))
+ (cons (/ n-mag g-mag) (/ d-mag g-mag))))))
+
+;; (define zz-0-0 (make-rat 0 0))
+(define zp-0-3 (make-rat 0 3))
+(define np-1-2 (make-rat -1 2))
+(define np-1-4 (make-rat -1 4))
+(define nn-3-4 (make-rat -3 -4))
+(define pp-4-3 (make-rat 4 3))
+(define pn-5-2 (make-rat 5 -2))
+(define pn-10-2 (make-rat 10 -2))
+(define nn-9-3 (make-rat -9 -3))
+
+;; (print-rat zz-0-0)
+;; (error "Division by zero")
+(print-rat zp-0-3)
+(display "=0/1")
+(print-rat np-1-2)
+(display "=-1/2")
+(print-rat np-1-4)
+(display "=-1/4")
+(print-rat nn-3-4)
+(display "=3/4")
+(print-rat pp-4-3)
+(display "=4/3")
+(print-rat pn-5-2)
+(display "=-5/2")
+(print-rat pn-10-2)
+(display "=-5/1")
+(print-rat nn-9-3)
+(display "=3/1")
+(print-rat (sub-rat nn-9-3 pp-4-3))
+(display "=5/3")
+(print-rat (mul-rat np-1-2 np-1-2))
+(display "=1/4")
+(print-rat (div-rat pn-5-2 pn-10-2))
+(display "=1/2")
+(print-rat (sub-rat np-1-4 zp-0-3))
+(display "=-1/4")
+;; (print-rat (div-rat nn-3-4 zp-0-3))
+;; (error "Division by zero")
+(print-rat (div-rat np-1-4 pn-5-2))
+(display "=1/10")
+
blob - /dev/null
blob + b138a9332e70faf79a8140b63b041a80059dfef8 (mode 644)
--- /dev/null
+++ ex2-1.scm~
+(define (linear-combination a b x y)
+ (+ (* a x) (* b y)))
+
+(define (linear-combination a b x y)
+ (add (mul a x) (mul b y)))
blob - /dev/null
blob + 10c2c8c5dfa23b89338dfc64d4017e07438f6d48 (mode 644)
--- /dev/null
+++ ex2-10.lisp
+(defun div-interval (x y)
+ (if (and
+ (>= (upper-bound y) 0)
+ (<= (lower-bound y) 0))
+ (error "Denominator spans zero")
+ (mul-interval
+ x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
blob - /dev/null
blob + c780e8f425fc2fe8225592c055ed0489e162bd25 (mode 644)
--- /dev/null
+++ ex2-10.lisp~
+(defun div-interval (x y)
+ (if (and
+ (>= (upper-bound y) 0)
+ (<= (lower-bound y) 0)
+ (error "Denominator spans zero")
+ (mul-interval
+ x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))))
blob - /dev/null
blob + 96060a461a48985df77282d2e728f2a4cab65247 (mode 644)
--- /dev/null
+++ ex2-10.scm
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+(define (mul-interval x y)
+ (let ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (div-interval x y)
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+
+;; Exercise 2.10. Ben Bitdiddle, an expert systems programmer, looks over Alyssa's shoulder and comments that it is not clear what it means to divide by an interval that spans zero. Modify Alyssa's code to check for this condition and to signal an error if it occurs.
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
blob - /dev/null
blob + d582b9d7cc181826cc14f2d73dad9501f8d2761f (mode 644)
--- /dev/null
+++ ex2-10.scm~
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+(define (mul-interval x y)
+ (let ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (div-interval x y)
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+
+;; Exercise 2.10. Ben Bitdiddle, an expert systems programmer, looks over Alyssa's shoulder and comments that it is not clear what it means to divide by an interval that spans zero. Modify Alyssa's code to check for this condition and to signal an error if it occurs.
blob - /dev/null
blob + 4d99ac8d461b3a995749d3774bcf80c433456ec1 (mode 644)
--- /dev/null
+++ ex2-11.scm
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+;; (define (div-interval x y)
+;; (mul-interval x
+;; (make-interval (/ 1.0 (upper-bound y))
+;; (/ 1.0 (lower-bound y)))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
+
+;; Exercise 2.11. In passing, Ben also cryptically comments: ``By testing the signs of the endpoints of the intervals, it is possible to break mul-interval into nine cases, only one of which requires more than two multiplications.'' Rewrite this procedure using Ben's suggestion.
+
+(define (mul-interval x y)
+ (let ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (mul-interval x y)
+ (let ((lx (lower-bound x))
+ (ly (lower-bound y))
+ (ux (upper-bound x))
+ (uy (upper-bound y)))
+ (cond ((and (< ux 0)
+ (< uy 0)) (make-interval (* ux uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (> ly 0)) (make-interval (* lx ly)
+ (* ux uy)))
+ ((and (< ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux ly)))
+ ((and (> lx 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx ly)))
+ ((and (< lx 0)
+ (> ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux uy)))
+ ((and (< ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* lx uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* ux ly)
+ (* ux uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (min (* lx uy)
+ (* ux ly))
+ (max (* lx lx)
+ (* ux uy)))))))
+
blob - /dev/null
blob + 96060a461a48985df77282d2e728f2a4cab65247 (mode 644)
--- /dev/null
+++ ex2-11.scm~
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+(define (mul-interval x y)
+ (let ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (div-interval x y)
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+
+;; Exercise 2.10. Ben Bitdiddle, an expert systems programmer, looks over Alyssa's shoulder and comments that it is not clear what it means to divide by an interval that spans zero. Modify Alyssa's code to check for this condition and to signal an error if it occurs.
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
blob - /dev/null
blob + e18c634c97605fb42c2a63bc72c7c8833526f55f (mode 644)
--- /dev/null
+++ ex2-12.lisp
+(defun make-center-percent (c p)
+ (let ((w (abs (* p (/ c 100)))))
+ (make-center-width c w)))
+(defun percent (i)
+ (* 100 (/ (width i) (abs (center i)))))
blob - /dev/null
blob + 483aa800871df2305017801f7bfa9d61c3681da8 (mode 644)
--- /dev/null
+++ ex2-12.scm
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
+
+(define (mul-interval x y)
+ (let ((lx (lower-bound x))
+ (ly (lower-bound y))
+ (ux (upper-bound x))
+ (uy (upper-bound y)))
+ (cond ((and (< ux 0)
+ (< uy 0)) (make-interval (* ux uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (> ly 0)) (make-interval (* lx ly)
+ (* ux uy)))
+ ((and (< ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux ly)))
+ ((and (> lx 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx ly)))
+ ((and (< lx 0)
+ (> ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux uy)))
+ ((and (< ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* lx uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* ux ly)
+ (* ux uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (min (* lx uy)
+ (* ux ly))
+ (max (* lx lx)
+ (* ux uy)))))))
+
+
+
+
+(define (make-center-width c w)
+ (make-interval (- c w) (+ c w)))
+(define (center i)
+ (/ (+ (lower-bound i) (upper-bound i)) 2))
+(define (width i)
+ (/ (- (upper-bound i) (lower-bound i)) 2))
+
+;; Exercise 2.12. Define a constructor make-center-percent that takes a center and a percentage tolerance and produces the desired interval. You must also define a selector percent that produces the percentage tolerance for a given interval. The center selector is the same as the one shown above.
+
+;; width/center = tolerance = percent / 100
+;; width = percent * center / 100
+(define (make-center-percent center percent)
+ (make-center-width center (* percent center 0.01)))
+
+;; percent = 100 * width / center
+(define (percent interval)
+ (/ (* 100 (width interval))
+ (center interval)))
+
+(define (print-interval interval)
+ (display "Lb: ")
+ (display (lower-bound interval))
+ (display " Ub: ")
+ (display (upper-bound interval))
+ (newline))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(print-interval (make-center-percent 100.0 10))
+(print-interval (make-interval 90.0 110.0))
+(test-case (percent (make-center-percent 100.0 10)) 10)
+(newline)
+(print-interval (make-center-percent 2.0 5))
+(print-interval (make-interval 1.9 2.1))
+(test-case (percent (make-center-percent 2.0 5)) 5)
+(newline)
+(print-interval (make-center-percent 1.0 3))
+(print-interval (make-interval 0.97 1.03))
+(newline)
+(test-case (percent (make-center-percent 1.0 3)) 3)
+(print-interval (make-center-percent 0 100))
+(print-interval (make-interval 0 0))
+;; this would give an error message...
+;; (test-case (percent (make-center-percent 0 100)) (error "Division by zero"))
+(print-interval (make-center-percent 25 0))
+(print-interval (make-interval 25 25))
+(test-case (percent (make-center-percent 25 0)) 0)
+
blob - /dev/null
blob + 26b0ce20e698e102fc931ceaf996a49607872303 (mode 644)
--- /dev/null
+++ ex2-12.scm~
+(define (make-center-width c w)
+ (make-interval (- c w) (+ c w)))
+(define (center i)
+ (/ (+ (lower-bound i) (upper-bound i)) 2))
+(define (width i)
+ (/ (- (upper-bound i) (lower-bound i)) 2))
blob - /dev/null
blob + d90414a70ecc05f10e0c903a312f36671028965d (mode 644)
--- /dev/null
+++ ex2-13.scm
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
+
+(define (mul-interval x y)
+ (let ((lx (lower-bound x))
+ (ly (lower-bound y))
+ (ux (upper-bound x))
+ (uy (upper-bound y)))
+ (cond ((and (< ux 0)
+ (< uy 0)) (make-interval (* ux uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (> ly 0)) (make-interval (* lx ly)
+ (* ux uy)))
+ ((and (< ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux ly)))
+ ((and (> lx 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx ly)))
+ ((and (< lx 0)
+ (> ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux uy)))
+ ((and (< ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* lx uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* ux ly)
+ (* ux uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (min (* lx uy)
+ (* ux ly))
+ (max (* lx lx)
+ (* ux uy)))))))
+
+
+
+
+(define (make-center-width c w)
+ (make-interval (- c w) (+ c w)))
+(define (center i)
+ (/ (+ (lower-bound i) (upper-bound i)) 2))
+(define (width i)
+ (/ (- (upper-bound i) (lower-bound i)) 2))
+
+;; Exercise 2.12. Define a constructor make-center-percent that takes a center and a percentage tolerance and produces the desired interval. You must also define a selector percent that produces the percentage tolerance for a given interval. The center selector is the same as the one shown above.
+
+;; width/center = tolerance = percent / 100
+;; width = percent * center / 100
+(define (make-center-percent center percent)
+ (make-center-width center (abs (* percent center 0.01))))
+
+;; percent = 100 * width / center
+(define (percent interval)
+ (/ (* 100 (width interval))
+ (abs (center interval))))
+
+(define (print-interval interval)
+ (display "Lb: ")
+ (display (lower-bound interval))
+ (display " Ub: ")
+ (display (upper-bound interval))
+ (newline))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(print-interval (make-center-percent 100.0 10))
+(print-interval (make-interval 90.0 110.0))
+(test-case (percent (make-center-percent 100.0 10)) 10)
+(newline)
+(print-interval (make-center-percent 2.0 5))
+(print-interval (make-interval 1.9 2.1))
+(test-case (percent (make-center-percent 2.0 5)) 5)
+(newline)
+(print-interval (make-center-percent 1.0 3))
+(print-interval (make-interval 0.97 1.03))
+(newline)
+(test-case (percent (make-center-percent 1.0 3)) 3)
+(print-interval (make-center-percent 0 100))
+(print-interval (make-interval 0 0))
+;; this would give an error message...
+;; (test-case (percent (make-center-percent 0 100)) (error "Division by zero"))
+(print-interval (make-center-percent 25 0))
+(print-interval (make-interval 25 25))
+(test-case (percent (make-center-percent 25 0)) 0)
+
blob - /dev/null
blob + 483aa800871df2305017801f7bfa9d61c3681da8 (mode 644)
--- /dev/null
+++ ex2-13.scm~
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
+
+(define (mul-interval x y)
+ (let ((lx (lower-bound x))
+ (ly (lower-bound y))
+ (ux (upper-bound x))
+ (uy (upper-bound y)))
+ (cond ((and (< ux 0)
+ (< uy 0)) (make-interval (* ux uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (> ly 0)) (make-interval (* lx ly)
+ (* ux uy)))
+ ((and (< ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux ly)))
+ ((and (> lx 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx ly)))
+ ((and (< lx 0)
+ (> ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux uy)))
+ ((and (< ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* lx uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* ux ly)
+ (* ux uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (min (* lx uy)
+ (* ux ly))
+ (max (* lx lx)
+ (* ux uy)))))))
+
+
+
+
+(define (make-center-width c w)
+ (make-interval (- c w) (+ c w)))
+(define (center i)
+ (/ (+ (lower-bound i) (upper-bound i)) 2))
+(define (width i)
+ (/ (- (upper-bound i) (lower-bound i)) 2))
+
+;; Exercise 2.12. Define a constructor make-center-percent that takes a center and a percentage tolerance and produces the desired interval. You must also define a selector percent that produces the percentage tolerance for a given interval. The center selector is the same as the one shown above.
+
+;; width/center = tolerance = percent / 100
+;; width = percent * center / 100
+(define (make-center-percent center percent)
+ (make-center-width center (* percent center 0.01)))
+
+;; percent = 100 * width / center
+(define (percent interval)
+ (/ (* 100 (width interval))
+ (center interval)))
+
+(define (print-interval interval)
+ (display "Lb: ")
+ (display (lower-bound interval))
+ (display " Ub: ")
+ (display (upper-bound interval))
+ (newline))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(print-interval (make-center-percent 100.0 10))
+(print-interval (make-interval 90.0 110.0))
+(test-case (percent (make-center-percent 100.0 10)) 10)
+(newline)
+(print-interval (make-center-percent 2.0 5))
+(print-interval (make-interval 1.9 2.1))
+(test-case (percent (make-center-percent 2.0 5)) 5)
+(newline)
+(print-interval (make-center-percent 1.0 3))
+(print-interval (make-interval 0.97 1.03))
+(newline)
+(test-case (percent (make-center-percent 1.0 3)) 3)
+(print-interval (make-center-percent 0 100))
+(print-interval (make-interval 0 0))
+;; this would give an error message...
+;; (test-case (percent (make-center-percent 0 100)) (error "Division by zero"))
+(print-interval (make-center-percent 25 0))
+(print-interval (make-interval 25 25))
+(test-case (percent (make-center-percent 25 0)) 0)
+
blob - /dev/null
blob + ccde8b6f7c9a26d13c24c983d3343970e426a1d0 (mode 644)
--- /dev/null
+++ ex2-14.lisp
+(defun par1 (r1 r2)
+ (div-interval
+ (mul-interval r1 r2)
+ (add-interval r1 r2)))
+(defun par2 (r1 r2)
+ (let ((one (make-interval 1 1)))
+ (div-interval
+ one
+ (add-interval (div-interval one r1)
+ (div-interval one r2)))))
+
+(defvar aa (make-center-width 5 0.1))
+(defvar bb (make-center-width 10 0.1))
+(print (par1 aa bb))
+(print (par2 aa bb))
blob - /dev/null
blob + 23335b796198966837adce56fd25e5c39a11e4ff (mode 644)
--- /dev/null
+++ ex2-14.lisp~
+(defun par1 (r1 r2)
+ (div-interval
+ (mul-interval r1 r2)
+ (add-interval r1 r2)))
+(defun par2 (r1 r2)
+ (let ((one (make-interval 1 1)))
+ (div-interval
+ one
+ (add-interval (div-interval one r1)
+ (div-interval one r2)))))
blob - /dev/null
blob + 705eac1e11ce76ac97bf113094cb455e6a7cb451 (mode 644)
--- /dev/null
+++ ex2-14.scm
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
+
+(define (mul-interval x y)
+ (let ((lx (lower-bound x))
+ (ly (lower-bound y))
+ (ux (upper-bound x))
+ (uy (upper-bound y)))
+ (cond ((and (< ux 0)
+ (< uy 0)) (make-interval (* ux uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (> ly 0)) (make-interval (* lx ly)
+ (* ux uy)))
+ ((and (< ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux ly)))
+ ((and (> lx 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx ly)))
+ ((and (< lx 0)
+ (> ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux uy)))
+ ((and (< ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* lx uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* ux ly)
+ (* ux uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (min (* lx uy)
+ (* ux ly))
+ (max (* lx lx)
+ (* ux uy)))))))
+
+
+
+
+(define (make-center-width c w)
+ (make-interval (- c w) (+ c w)))
+(define (center i)
+ (/ (+ (lower-bound i) (upper-bound i)) 2))
+(define (width i)
+ (/ (- (upper-bound i) (lower-bound i)) 2))
+
+;; width/center = tolerance = percent / 100
+;; width = percent * center / 100
+(define (make-center-percent center percent)
+ (make-center-width center (abs (* percent center 0.01))))
+
+;; percent = 100 * width / center
+(define (percent interval)
+ (/ (* 100 (width interval))
+ (abs (center interval))))
+
+(define (print-interval interval)
+ (display "Lb: ")
+ (display (lower-bound interval))
+ (display " Ub: ")
+ (display (upper-bound interval))
+ (newline))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(print-interval (make-center-percent 100.0 10))
+(print-interval (make-interval 90.0 110.0))
+(test-case (percent (make-center-percent 100.0 10)) 10)
+(newline)
+(print-interval (make-center-percent 2.0 5))
+(print-interval (make-interval 1.9 2.1))
+(test-case (percent (make-center-percent 2.0 5)) 5)
+(newline)
+(print-interval (make-center-percent 1.0 3))
+(print-interval (make-interval 0.97 1.03))
+(newline)
+(test-case (percent (make-center-percent 1.0 3)) 3)
+(print-interval (make-center-percent 0 100))
+(print-interval (make-interval 0 0))
+;; this would give an error message...
+;; (test-case (percent (make-center-percent 0 100)) (error "Division by zero"))
+(print-interval (make-center-percent 25 0))
+(print-interval (make-interval 25 25))
+(test-case (percent (make-center-percent 25 0)) 0)
+
+(define (par1 r1 r2)
+ (div-interval (mul-interval r1 r2)
+ (add-interval r1 r2)))
+(define (par2 r1 r2)
+ (let ((one (make-interval 1 1)))
+ (div-interval one
+ (add-interval (div-interval one r1)
+ (div-interval one r2)))))
+
+(newline)
+(print-interval (par1 (make-center-percent 25 5) (make-center-percent 20 3)))
+(print-interval (par2 (make-center-percent 25 5) (make-center-percent 20 3)))
+;; both should be equal and centered around 11.11, but this is not so
+
+(print-interval (div-interval (make-center-percent 25 1)
+ (make-center-percent 25 1)))
+
+;; we'd expect this to give exactly 1?
+
blob - /dev/null
blob + 02d531b90d4cf19e069322f3f19835f291af7645 (mode 644)
--- /dev/null
+++ ex2-14.scm~
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+(define (div-interval x y)
+ (define (spans-zero? interval)
+ (and (<= (lower-bound interval) 0)
+ (<= 0 (upper-bound interval))))
+ (if (spans-zero? y)
+ (error "Division by zero")
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y))))))
+
+(define (mul-interval x y)
+ (let ((lx (lower-bound x))
+ (ly (lower-bound y))
+ (ux (upper-bound x))
+ (uy (upper-bound y)))
+ (cond ((and (< ux 0)
+ (< uy 0)) (make-interval (* ux uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (> ly 0)) (make-interval (* lx ly)
+ (* ux uy)))
+ ((and (< ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux ly)))
+ ((and (> lx 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< uy 0)) (make-interval (* ux ly)
+ (* lx ly)))
+ ((and (< lx 0)
+ (> ux 0)
+ (> ly 0)) (make-interval (* lx uy)
+ (* ux uy)))
+ ((and (< ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* lx uy)
+ (* lx ly)))
+ ((and (> lx 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (* ux ly)
+ (* ux uy)))
+ ((and (< lx 0)
+ (> ux 0)
+ (< ly 0)
+ (> uy 0)) (make-interval (min (* lx uy)
+ (* ux ly))
+ (max (* lx lx)
+ (* ux uy)))))))
+
+
+
+
+(define (make-center-width c w)
+ (make-interval (- c w) (+ c w)))
+(define (center i)
+ (/ (+ (lower-bound i) (upper-bound i)) 2))
+(define (width i)
+ (/ (- (upper-bound i) (lower-bound i)) 2))
+
+;; width/center = tolerance = percent / 100
+;; width = percent * center / 100
+(define (make-center-percent center percent)
+ (make-center-width center (abs (* percent center 0.01))))
+
+;; percent = 100 * width / center
+(define (percent interval)
+ (/ (* 100 (width interval))
+ (abs (center interval))))
+
+(define (print-interval interval)
+ (display "Lb: ")
+ (display (lower-bound interval))
+ (display " Ub: ")
+ (display (upper-bound interval))
+ (newline))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(print-interval (make-center-percent 100.0 10))
+(print-interval (make-interval 90.0 110.0))
+(test-case (percent (make-center-percent 100.0 10)) 10)
+(newline)
+(print-interval (make-center-percent 2.0 5))
+(print-interval (make-interval 1.9 2.1))
+(test-case (percent (make-center-percent 2.0 5)) 5)
+(newline)
+(print-interval (make-center-percent 1.0 3))
+(print-interval (make-interval 0.97 1.03))
+(newline)
+(test-case (percent (make-center-percent 1.0 3)) 3)
+(print-interval (make-center-percent 0 100))
+(print-interval (make-interval 0 0))
+;; this would give an error message...
+;; (test-case (percent (make-center-percent 0 100)) (error "Division by zero"))
+(print-interval (make-center-percent 25 0))
+(print-interval (make-interval 25 25))
+(test-case (percent (make-center-percent 25 0)) 0)
+
+(define (par1 r1 r2)
+ (div-interval (mul-interval r1 r2)
+ (add-interval r1 r2)))
+(define (par2 r1 r2)
+ (let ((one (make-interval 1 1)))
+ (div-interval one
+ (add-interval (div-interval one r1)
+ (div-interval one r2)))))
+
+(newline)
+(print-interval (par1 (make-center-percent 25 5) (make-center-percent 20 3)))
+(print-interval (par2 (make-center-percent 25 5) (make-center-percent 20 3)))
+;; both should be equal and centered around 11.11, but this is not so
+
+(print-interval (div-interval (make-center-percent 25 1n)
+ (make-center-percent 25 1)))
+
+;; we'd expect this to give exactly 1?
+
blob - /dev/null
blob + a04d4d1ab137708374750dd1c8edcb0eb28d7729 (mode 644)
--- /dev/null
+++ ex2-14b.scm
+(define (par1 r1 r2)
+ (div-interval (mul-interval r1 r2)
+ (add-interval r1 r2)))
+(define (par2 r1 r2)
+ (let ((one (make-interval 1 1)))
+ (div-interval one
+ (add-interval (div-interval one r1)
+ (div-interval r2)))))
blob - /dev/null
blob + e5398d99e9112df56d7322d0452fea8d7a167c14 (mode 644)
--- /dev/null
+++ ex2-17.lisp
+(defun last-pair (items)
+ (if (null (cdr items))
+ items
+ (last-pair (cdr items))))
blob - /dev/null
blob + 7a256898f2d60e1ccb14deb454ea1474de7b3715 (mode 644)
--- /dev/null
+++ ex2-17.lisp~
+(defun last-pair (items)
+ (if (null (cdr items))
blob - /dev/null
blob + 9041673d15286cfebda77b1aff70e6f58cbe4022 (mode 644)
--- /dev/null
+++ ex2-17.scm
+(define (list-ref items n)
+ (if (= n 0)
+ (cat items)
+ (list-ref (cdr items) (- n 1))))
+
+(define (length items)
+ (define (length-ter a count)
+ (if (null? a)
+ count
+ (length-iter (cdr a) (+ 1 count))))
+ (length-iter items 0))
+
+(define (append list1 list2)
+ (if (null? list1)
+ list2
+ (cons (car list1)
+ (append (cdr list1) list2))))
+
+(define (last-pair l)
+ (cond ((null? l) (error "Empty List"))
+ ((null? (cdr l)) l)
+ (else (last-pair (cdr l)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (last-pair (list 23 72 149 34)) '(34))
+;; ;; (test-case (last-pair '()) (error "Empty List"))
+;; (test-case (last-pair (list 4)) '(4))
+
+(define (reverse l)
+ (if (null? l)
+ '()
+ (append
+ (reverse (cdr l))
+ (car l))))
+
+(test-case (reverse (list 1 4 9 16 25)) '(25 16 9 4 1))
+(test-case (reverse (list)) '())
+(test-case (reverse (list 4)) '(4))
blob - /dev/null
blob + 7d6072b30102939d8494c0ecd49d9d79fa12fa69 (mode 644)
--- /dev/null
+++ ex2-17.scm~
+(define one-through-four (list 1 2 3 4))
+one-through-four
blob - /dev/null
blob + 6b0a2b37c5201aefbe46f38cb282b747a33f005a (mode 644)
--- /dev/null
+++ ex2-18.lisp
+(defun my-reverse (items)
+ (if (null items)
+ nil
+ (append
+ (my-reverse (cdr items))
+ (list (car items)))))
+
+
blob - /dev/null
blob + c6fa8da372810f8bb0c042b32e832629f3101ce6 (mode 644)
--- /dev/null
+++ ex2-18.lisp~
+(defun my-reverse (items)
+ (if (null items)
+ nil
+ (append
+ (my-reverse (cdr items)
+ (list (car items))))))
blob - /dev/null
blob + ab1e1fc6103ac7689cc6084d61e6e900cbae0c79 (mode 644)
--- /dev/null
+++ ex2-18.scm
+(define (list-ref items n)
+ (if (= n 0)
+ (cat items)
+ (list-ref (cdr items) (- n 1))))
+
+(define (length items)
+ (define (length-ter a count)
+ (if (null? a)
+ count
+ (length-iter (cdr a) (+ 1 count))))
+ (length-iter items 0))
+
+(define (append list1 list2)
+ (if (null? list1)
+ list2
+ (cons (car list1)
+ (append (cdr list1) list2))))
+
+(define (last-pair l)
+ (cond ((null? l) (error "Empty List"))
+ ((null? (cdr l)) l)
+ (else (last-pair (cdr l)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (last-pair (list 23 72 149 34)) '(34))
+;; ;; (test-case (last-pair '()) (error "Empty List"))
+;; (test-case (last-pair (list 4)) '(4))
+
+(define (reverse l)
+ (if (null? l)
+ '()
+ (append
+ (reverse (cdr l))
+ (list (car l)))))
+
+(test-case (reverse (list 1 4 9 16 25)) '(25 16 9 4 1))
+(test-case (reverse (list)) '())
+(test-case (reverse (list 4)) '(4))
blob - /dev/null
blob + 9041673d15286cfebda77b1aff70e6f58cbe4022 (mode 644)
--- /dev/null
+++ ex2-18.scm~
+(define (list-ref items n)
+ (if (= n 0)
+ (cat items)
+ (list-ref (cdr items) (- n 1))))
+
+(define (length items)
+ (define (length-ter a count)
+ (if (null? a)
+ count
+ (length-iter (cdr a) (+ 1 count))))
+ (length-iter items 0))
+
+(define (append list1 list2)
+ (if (null? list1)
+ list2
+ (cons (car list1)
+ (append (cdr list1) list2))))
+
+(define (last-pair l)
+ (cond ((null? l) (error "Empty List"))
+ ((null? (cdr l)) l)
+ (else (last-pair (cdr l)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (last-pair (list 23 72 149 34)) '(34))
+;; ;; (test-case (last-pair '()) (error "Empty List"))
+;; (test-case (last-pair (list 4)) '(4))
+
+(define (reverse l)
+ (if (null? l)
+ '()
+ (append
+ (reverse (cdr l))
+ (car l))))
+
+(test-case (reverse (list 1 4 9 16 25)) '(25 16 9 4 1))
+(test-case (reverse (list)) '())
+(test-case (reverse (list 4)) '(4))
blob - /dev/null
blob + aa0b7519188a9176c40e36b0747fbfd87e600ecb (mode 644)
--- /dev/null
+++ ex2-19.lisp
+(defun no-more? (coins)
+ (null coins))
+(defun except-first-denomination (coins)
+ (cdr coins))
+(defun first-denomination (oins)
+ (car coins))
+(defun cc (amount coin-values)
+ (cond ((= amount 0) 1)
+ ((or (< amount 0) (no-more? coin-values)) 0)
+ (t
+ (+ (cc amount
+ (except-first-denomination coin-values))
+ (cc (- amount
+ (first-denomination coin-values))
+ coin-values)))))
blob - /dev/null
blob + 6b0a2b37c5201aefbe46f38cb282b747a33f005a (mode 644)
--- /dev/null
+++ ex2-19.lisp~
+(defun my-reverse (items)
+ (if (null items)
+ nil
+ (append
+ (my-reverse (cdr items))
+ (list (car items)))))
+
+
blob - /dev/null
blob + 8efa82e7078d09516d795203da315223129cc911 (mode 644)
--- /dev/null
+++ ex2-19.scm
+(define (list-ref items n)
+ (if (= n 0)
+ (cat items)
+ (list-ref (cdr items) (- n 1))))
+
+(define (length items)
+ (define (length-ter a count)
+ (if (null? a)
+ count
+ (length-iter (cdr a) (+ 1 count))))
+ (length-iter items 0))
+
+(define (append list1 list2)
+ (if (null? list1)
+ list2
+ (cons (car list1)
+ (append (cdr list1) list2))))
+
+(define (last-pair l)
+ (cond ((null? l) (error "Empty List"))
+ ((null? (cdr l)) l)
+ (else (last-pair (cdr l)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define (reverse l)
+ (if (null? l)
+ '()
+ (append
+ (reverse (cdr l))
+ (list (car l)))))
+
+(define us-coins (list 50 25 10 5 1))
+(define uk-coins (list 100 50 20 10 5 2 1 0.5))
+
+(define (cc amount coin-values)
+ (cond ((= amount 0) 1)
+ ((or (< amount 0) (no-more? coin-values)) 0)
+ (else
+ (+ (cc amount
+ (except-first-denomination coin-values))
+ (cc (- amount
+ (first-denomination coin-values))
+ coin-values)))))
+
+;; Define the procedures first-denomination, except-first-denomination, and no-more? in terms of primitive operations on list structures. Does the order of the list coin-values affect the answer produced by cc? Why or why not?
+
+(define first-denomination car)
+(define except-first-denomination cdr)
+(define no-more? null?)
+
+;; no, order of coin-values shouldn't matter because it doesn't matter in reali life
+
+(test-case (cc 100 us-coins) 292)
blob - /dev/null
blob + ab1e1fc6103ac7689cc6084d61e6e900cbae0c79 (mode 644)
--- /dev/null
+++ ex2-19.scm~
+(define (list-ref items n)
+ (if (= n 0)
+ (cat items)
+ (list-ref (cdr items) (- n 1))))
+
+(define (length items)
+ (define (length-ter a count)
+ (if (null? a)
+ count
+ (length-iter (cdr a) (+ 1 count))))
+ (length-iter items 0))
+
+(define (append list1 list2)
+ (if (null? list1)
+ list2
+ (cons (car list1)
+ (append (cdr list1) list2))))
+
+(define (last-pair l)
+ (cond ((null? l) (error "Empty List"))
+ ((null? (cdr l)) l)
+ (else (last-pair (cdr l)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+;; (test-case (last-pair (list 23 72 149 34)) '(34))
+;; ;; (test-case (last-pair '()) (error "Empty List"))
+;; (test-case (last-pair (list 4)) '(4))
+
+(define (reverse l)
+ (if (null? l)
+ '()
+ (append
+ (reverse (cdr l))
+ (list (car l)))))
+
+(test-case (reverse (list 1 4 9 16 25)) '(25 16 9 4 1))
+(test-case (reverse (list)) '())
+(test-case (reverse (list 4)) '(4))
blob - /dev/null
blob + 59da5eaacbe69d770adfa118c9dea5307a256b0f (mode 644)
--- /dev/null
+++ ex2-2.lisp
+(defun make-segment (start end)
+ (cons start end))
+(defun start-segment (segment)
+ (car segment))
+(defun end-segment (segment)
+ (cdr segment))
+(defun make-point (x y)
+ (cons x y))
+(defun x-point (point)
+ (car point))
+(defun y-point (point)
+ (cdr point))
+(defun print-point (point)
+ (format t "(~F,~F)~%" (x-point point) (y-point point)))
+(defun midpoint-segment (segment)
+ (let ((segstart (start-segment segment))
+ (segend (end-segment segment)))
+ (make-point (average (x-point segstart)
+ (x-point segend))
+ (average (y-point segstart)
+ (y-point segend)))))
+(defvar aa (make-point 4 6))
+(defvar bb (make-point 9 15))
+(print-point
+ (midpoint-segment (make-segment aa bb)))
+
blob - /dev/null
blob + 21f611c03dc9ffde375c305fc7729681cb62e91e (mode 644)
--- /dev/null
+++ ex2-2.lisp~
+(defun make-segment (start end)
+ (cons start end))
blob - /dev/null
blob + 9c4f17a102178e64c30b374fa056442df93373e5 (mode 644)
--- /dev/null
+++ ex2-2.scm
+;; Exercise 2.2. Consider the problem of representing line segments in a plane. Each segment is represented as a pair of points: a starting point and an ending point. Define a constructor make-segment and selectors start-segment and end-segment that define the representation of segments in terms of points. Furthermore, a point can be represented as a pair of numbers: the x coordinate and the y coordinate. Accordingly, specify a constructor make-point and selectors x-point and y-point that define this representation. Finally, using your selectors and constructors, define a procedure midpoint-segment that takes a line segment as argument and returns its midpoint (the point whose coordinates are the average of the coordinates of the endpoints). To try your procedures, you'll need a way to print points:
+
+(define (make-point x y)
+ (cons x y))
+(define (x-point p)
+ (car p))
+(define (y-point p)
+ (cdr p))
+
+(define (make-segment start end)
+ (cons start end))
+(define (start-segment seg)
+ (car seg))
+(define (end-segment seg)
+ (cdr seg))
+(define (midpoint-segment seg)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (let ((x1 (x-point (start-segment seg)))
+ (x2 (x-point (end-segment seg)))
+ (y1 (y-point (start-segment seg)))
+ (y2 (y-point (end-segment seg))))
+ (make-point (average x1 x2)
+ (average y1 y2))))
+
+(define (print-point p)
+ (newline)
+ (display "(")
+ (display (x-point p))
+ (display ",")
+ (display (y-point p))
+ (display ")"))
+
+(define x1y2 (make-point 1 2))
+(define x-4y-3 (make-point -4 -3))
+(define x1y2tox-4y-3 (make-segment x1y2 x-4y-3))
+(print-point (midpoint-segment x1y2tox-4y-3))
+(display "=(-3/2,-1/2)")
blob - /dev/null
blob + 31a3df3302f2f5d624e49dc95efcd395df9a71fb (mode 644)
--- /dev/null
+++ ex2-2.scm~
+(define (make-rat n d)
+ (cons n d))
+(define (numer x)
+ (let ((g (gcd (car x) (cdr x))))
+ (/ (car x) g)))
+(define (denom x)
+ (let ((g (gcd (car x) (cdr x))))
+ (/ (cdr x) g)))
+
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 7684e7f06971d8860461eb6ef2b108a3e1c5ad9e (mode 644)
--- /dev/null
+++ ex2-20.scm
+;; Use this notation to write a procedure same-parity that takes one or more integers and returns a list of all the arguments that have the same even-odd parity as the first argument. For example,
+
+;; (define (same-parity parity . integers)
+;; (let ((rem (remainder parity 2)))
+;; (define (par ints)
+;; (cond ((null? ints) '())
+;; ((= (remainder (car ints) 2) rem)
+;; (cons (car ints)
+;; (par (cdr ints))))
+;; (else (par (cdr ints))))))
+;; (cons parity (par integers)))
+
+;; par seems not to be in scope in the call at the end
+
+
+(define (same-parity parity . integers)
+ (let ((rem (remainder parity 2)))
+ (define (par ints)
+ (cond ((null? ints) '())
+ ((= (remainder (car ints) 2) rem)
+ (cons (car ints)
+ (par (cdr ints))))
+ (else (par (cdr ints)))))
+ (cons parity (par integers))))
+
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (same-parity 1 2 3 4 5 6 7) '(1 3 5 7))
+(test-case (same-parity 2 3 4 5 6 7) '(2 4 6))
+(test-case (same-parity 5) '(5))
+;;(test-case (same-parity) (error "Expected argument"))
blob - /dev/null
blob + 555bac319e12d29de9b2f007cc6291478b945c52 (mode 644)
--- /dev/null
+++ ex2-20.scm~
+;; Use this notation to write a procedure same-parity that takes one or more integers and returns a list of all the arguments that have the same even-odd parity as the first argument. For example,
+
+;; (define (same-parity parity . integers)
+;; (let ((rem (remainder parity 2)))
+;; (define (par ints)
+;; (cond ((null? ints) '())
+;; ((= (remainder (car ints) 2) rem)
+;; (cons (car ints)
+;; (par (cdr ints))))
+;; (else (par (cdr ints))))))
+;; (cons parity (par integers)))
+
+;; par seems not to be in scope in the call at the end
+
+
+(define (same-parity parity . integers)
+ (let ((rem (remainder parity 2)))
+ (define (par ints)
+ (cond ((null? ints) '())
+ ((= (remainder (car ints) 2) rem)
+ (cons (car ints)
+ (par (cdr ints))))
+ (else (par (cdr ints)))))
+ (cons parity (par integers))))
+
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (same-parity 1 2 3 4 5 6 7) '(1 3 5 7))
+(test-case (same-parity 2 3 4 5 6 7) '(2 4 6))
blob - /dev/null
blob + fa86a7231a3d9fa3188d74cd60b3b5fc8b36982a (mode 644)
--- /dev/null
+++ ex2-20b.scm
+(define (same-parity a . z)
+ (define (iter items answer)
+ (if (null? items)
+ answer
+ (iter (cdr items)
+ (if (= (remainder (car items) 2)
+ (remainder a 2))
+ (append answer (list (car items)))
+ answer))))
+ (iter z (list a)))
blob - /dev/null
blob + 060e7a9cdf67dab7dd294a3d7fc0c116338fde96 (mode 644)
--- /dev/null
+++ ex2-21.lisp
+(defun square-list-solo (items)
+ (if (null items)
+ nil
+ (cons (square (car items))
+ (square-list-solo (cdr items)))))
+(defun square-list-map (items)
+ (mapcar #'square items))
blob - /dev/null
blob + f6e3a3426f5e06d21555df5cb7b6811b5401a2d6 (mode 644)
--- /dev/null
+++ ex2-21.scm
+(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items)))))
+
+(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items))
+
+;; Exercise 2.21. The procedure square-list takes a list of numbers as argument and returns a list of the squares of those numbers.
+
+(define (square-list-map nums)
+ (map (lambda (x) (* x x)) nums))
+
+(define (square-list-recurse nums)
+ (if (null? nums)
+ '()
+ (cons (* (car nums) (car nums))
+ (square-list-recurse (cdr nums)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (square-list-recurse (list 1 2 3 4)) '(1 4 9 16))
+(test-case (square-list-map (list 1 2 3 4)) '(1 4 9 16))
+
blob - /dev/null
blob + 317aa9e8bbadc63e7c2a837f087306cd6afa6dbd (mode 644)
--- /dev/null
+++ ex2-21.scm~
+(define (scale-list items factor)
+ (if (null? items)
+ nil
+ (cons (* (car items) factor)
+ (scale-list (cdr items) factor))))
+(scale-list (list 1 2 3 4 5) 10)
blob - /dev/null
blob + 568eb49849f867bea5c092aa20695146c978f6dd (mode 644)
--- /dev/null
+++ ex2-22.lisp
+(defun square-list-solo (items)
+ (if (null items)
+ nil
+ (cons (square (car items))
+ (square-list-solo (cdr items)))))
+(defun square-list-map (items)
+ (mapcar #'square items))
+
+(defun square-list-iter (items)
+ (labels (
+ (iter (things answer)
+ (format t "~A - ~A~%" things answer)
+ (if (null things)
+ answer
+ (iter (cdr things)
+ (cons (square (car things))
+ answer)))))
+ (iter items nil)))
+(print (square-list-iter '(1 2 3 4)))
blob - /dev/null
blob + 060e7a9cdf67dab7dd294a3d7fc0c116338fde96 (mode 644)
--- /dev/null
+++ ex2-22.lisp~
+(defun square-list-solo (items)
+ (if (null items)
+ nil
+ (cons (square (car items))
+ (square-list-solo (cdr items)))))
+(defun square-list-map (items)
+ (mapcar #'square items))
blob - /dev/null
blob + a817b13042b32f737b5303c1029fc5193fc5a95d (mode 644)
--- /dev/null
+++ ex2-22.scm
+(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items)))))
+
+(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items))
+
+(define (square-list-map nums)
+ (map (lambda (x) (* x x)) nums))
+
+(define (square-list-recurse nums)
+ (if (null? nums)
+ '()
+ (cons (* (car nums) (car nums))
+ (square-list-recurse (cdr nums)))))
+
+;; Exercise 2.22. Louis Reasoner tries to rewrite the first square-list procedure of exercise 2.21 so that it evolves an iterative process:
+
+(define (square-list items)
+ (define (iter things answer)
+ (if (null? things)
+ answer
+ (iter (cdr things)
+ (cons (square (car things))
+ answer))))
+ (iter items nil))
+
+;; (cons (square (car things))
+;; answer)
+;; puts the next number in front of its previous number, but we should be
+;; putting the next number behind the previous number
+;; that's why the numbers appear reversed in the resulting list
+
+;; Louis then tries to fix his bug by interchanging the arguments to cons:
+
+(define (square-list items)
+ (define (iter things answer)
+ (if (null? things)
+ answer
+ (iter (cdr things)
+ (cons answer
+ (square (car things))))))
+ (iter items nil))
+
+;; This doesn't work either. Explain.
+
+;; answer is a list whereas (square (car things)) is a number. So although
+;; the order is right, you end up with nested lists. We should instead be
+;; using (append answer (list (square (car things))))
+;; to append two lists
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
blob - /dev/null
blob + 517db1decd35dc81fd403875038302c8d01fef2b (mode 644)
--- /dev/null
+++ ex2-22.scm~
+(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items)))))
+
+(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items))
+
+;; Exercise 2.21. The procedure square-list takes a list of numbers as argument and returns a list of the squares of those numbers.
+
+(define (square-list-map nums)
+ (map (lambda (x) (* x x)) nums))
+
+(define (square-list-recurse nums)
+ (if (null? nums)
+ '()
+ (cons (* (car nums) (car nums))
+ (square-list-recurse (cdr nums)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (square-list-recurse (list 1 2 3 4)) '(1 4 9 16))
+(test-case (square-list-map (list 1 2 3 4)) '(1 4 9 16))
+
+ Exercise 2.22. Louis Reasoner tries to rewrite the first square-list procedure of exercise 2.21 so that it evolves an iterative process:
+
+(define (square-list items)
+ (define (iter things answer)
+ (if (null? things)
+ answer
+ (iter (cdr things)
+ (cons (square (car things))
+ answer))))
+ (iter items nil))
+
+Unfortunately, defining square-list this way produces the answer list in the reverse order of the one desired. Why?
+
+Louis then tries to fix his bug by interchanging the arguments to cons:
+
+(define (square-list items)
+ (define (iter things answer)
+ (if (null? things)
+ answer
+ (iter (cdr things)
+ (cons answer
+ (square (car things))))))
+ (iter items nil))
+
+This doesn't work either. Explain.
blob - /dev/null
blob + 201bbd5d5864e8c06c14a11a799abb4b932b1f9d (mode 644)
--- /dev/null
+++ ex2-23.scm
+;; Exercise 2.23. The procedure for-each is similar to map. It takes as arguments a procedure and a list of elements. However, rather than forming a list of the results, for-each just applies the procedure to each of the elements in turn, from left to right. The values returned by applying the procedure to the elements are not used at all -- for-each is used with procedures that perform an action, such as printing. For example,
+
+(define (for-each proc items)
+ (if (null? items)
+ #t
+ (and (proc (car items))
+ (for-each proc (cdr items)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(for-each (lambda (x) (newline) (display x))
+ (list 57 321 88))
+(newline)
+(display 57)
+(newline)
+(display 321)
+(newline)
+(display 88)
+
+
blob - /dev/null
blob + 568eb49849f867bea5c092aa20695146c978f6dd (mode 644)
--- /dev/null
+++ ex2-23.scm~
+(defun square-list-solo (items)
+ (if (null items)
+ nil
+ (cons (square (car items))
+ (square-list-solo (cdr items)))))
+(defun square-list-map (items)
+ (mapcar #'square items))
+
+(defun square-list-iter (items)
+ (labels (
+ (iter (things answer)
+ (format t "~A - ~A~%" things answer)
+ (if (null things)
+ answer
+ (iter (cdr things)
+ (cons (square (car things))
+ answer)))))
+ (iter items nil)))
+(print (square-list-iter '(1 2 3 4)))
blob - /dev/null
blob + edaa4aa1f68dc3754190657801e20d3aaae1f9bb (mode 644)
--- /dev/null
+++ ex2-24.scm
+(define (count-leaves x)
+ (cond ((null? x) 0)
+ ((not (pair? x)) 1)
+ (else (+ (count-leaves (car x))
+ (count-leaves (cdr x))))))
+
+(list 1 (list 2 (list 3 4)))
+'(1 (2 (3 4)))
blob - /dev/null
blob + 201bbd5d5864e8c06c14a11a799abb4b932b1f9d (mode 644)
--- /dev/null
+++ ex2-24.scm~
+;; Exercise 2.23. The procedure for-each is similar to map. It takes as arguments a procedure and a list of elements. However, rather than forming a list of the results, for-each just applies the procedure to each of the elements in turn, from left to right. The values returned by applying the procedure to the elements are not used at all -- for-each is used with procedures that perform an action, such as printing. For example,
+
+(define (for-each proc items)
+ (if (null? items)
+ #t
+ (and (proc (car items))
+ (for-each proc (cdr items)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(for-each (lambda (x) (newline) (display x))
+ (list 57 321 88))
+(newline)
+(display 57)
+(newline)
+(display 321)
+(newline)
+(display 88)
+
+
blob - /dev/null
blob + 7ccd2c4b515e06df44e4dc93ca4c47ece540ad59 (mode 644)
--- /dev/null
+++ ex2-25.lisp
+(cadaddr '(1 3 (5 7) 9)))
+
+(caar '((7)))
+
+(cadadadadadadr (1 (2 (3 (4 (5 (6 7)))))))
blob - /dev/null
blob + bfc90827888613b4d9016b4b23d18b0693e21bf2 (mode 644)
--- /dev/null
+++ ex2-25.scm
+(define (count-leaves x)
+ (cond ((null? x) 0)
+ ((not (pair? x)) 1)
+ (else (+ (count-leaves (car x))
+ (count-leaves (cdr x))))))
+
+;;(list 1 (list 2 (list 3 4)))
+;;'(1 (2 (3 4)))
+
+;; Exercise 2.26. Suppose we define x and y to be two lists:
+
+(define x (list 1 2 3))
+(define y (list 4 5 6))
+
+;; What result is printed by the interpreter in response to evaluating each of the following expressions:
+
+(display (append x y))
+(newline)
+(display '(1 2 3 4 5 6))
+(newline)
+(newline)
+
+(display (cons x y))
+(newline)
+(display '((1 2 3) 4 5 6))
+(newline)
+(newline)
+
+(display (list x y))
+(newline)
+(display '((1 2 3) (4 5 6)))
+(newline)
blob - /dev/null
blob + 2b25c4b9e68529b537ad05ba267fb802b7070866 (mode 644)
--- /dev/null
+++ ex2-25.scm~
+(define (count-leaves x)
+ (cond ((null? x) 0)
+ ((not (pair? x)) 1)
+ (else (+ (count-leaves (car x))
+ (count-leaves (cdr x))))))
+
+;;(list 1 (list 2 (list 3 4)))
+;;'(1 (2 (3 4)))
+
+;; Exercise 2.26. Suppose we define x and y to be two lists:
+
+(define x (list 1 2 3))
+(define y (list 4 5 6))
+
+;; What result is printed by the interpreter in response to evaluating each of the following expressions:
+
+(display (append x y))
+(newline)
+(display '(1 2 3 4 5 6))
+(newline)
+(newline)
+
+(display (cons x y))
+(newline)
+(display '((1 2 3) 4 5 6))
+(newline)
+(newline)
+
+(display (list x y))
+(newline)
+(display '((1 2 3) (4 5 6))
+(newline)
blob - /dev/null
blob + 2530e791e49be2f79417dcd587432e909effb6b1 (mode 644)
--- /dev/null
+++ ex2-27.lisp
+(defun deep-reverse (lst)
+ (cond ((null lst) nil)
+ ((consp (car lst))
+ (append
+ (deep-reverse (cdr lst))
+ (list (deep-reverse (car lst)))))
+ (t
+ (append
+ (deep-reverse (cdr lst))
+ (list (car lst))))))
blob - /dev/null
blob + 770d199fbd9028d8cdf421b8fd776ac5b9aaae4d (mode 644)
--- /dev/null
+++ ex2-27.scm
+;; Exercise 2.27. Modify your reverse procedure of exercise 2.18 to produce a deep-reverse procedure that takes a list as argument and returns as its value the list with its elements reversed and with all sublists deep-reversed as well. For example,
+
+(define (deep-reverse tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) tree)
+ (else (append
+ (deep-reverse (cdr tree))
+ (list (deep-reverse (car tree)))))))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define x (list (list 1 2) (list 3 4)))
+
+(test-case (reverse x) '((3 4) (1 2)))
+
+(test-case (deep-reverse x) '((4 3) (2 1)))
blob - /dev/null
blob + bf58fc259980b97e6f378c80960e08c1a04360a6 (mode 644)
--- /dev/null
+++ ex2-27.scm~
+;; Exercise 2.27. Modify your reverse procedure of exercise 2.18 to produce a deep-reverse procedure that takes a list as argument and returns as its value the list with its elements reversed and with all sublists deep-reversed as well. For example,
+
+(define (deep-reverse tree)
+ (cond ((null? tree) ...)
+ ((not (pair? tree)) ...)
+ (else ...)))
+
+(define x (list (list 1 2) (list 3 4)))
+
+x
+((1 2) (3 4))
+
+(reverse x)
+((3 4) (1 2))
+
+(deep-reverse x)
+((4 3) (2 1))
blob - /dev/null
blob + 16dfc58e2160eb0e4059d130a0bafa8255c51c76 (mode 644)
--- /dev/null
+++ ex2-28.lisp
+(defun fringe (lst)
+ (cond ((null lst) nil)
+ ((not (consp lst)) (list lst))
+ (t (append (fringe (car lst))
+ (fringe cdr lst)))))
blob - /dev/null
blob + f2ca7a0679ea92bc35d1f0145fae9e3a4c35c2c4 (mode 644)
--- /dev/null
+++ ex2-28.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (deep-reverse tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) tree)
+ (else (append
+ (deep-reverse (cdr tree))
+ (list (deep-reverse (car tree)))))))
+
+;; (define x (list (list 1 2) (list 3 4)))
+;; (test-case (reverse x) '((3 4) (1 2)))
+;; (test-case (deep-reverse x) '((4 3) (2 1)))
+
+
+;;Exercise 2.28. Write a procedure fringe that takes as argument a tree (represented as a list) and returns a list whose elements are all the leaves of the tree arranged in left-to-right order. For example,
+
+(define (fringe tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (list tree))
+ (else (append (fringe (car tree))
+ (fringe (cdr tree))))))
+
+
+(define x (list (list 1 2) (list 3 4)))
+(test-case (fringe x) '(1 2 3 4))
+(test-case (fringe (list x x)) '(1 2 3 4 1 2 3 4))
blob - /dev/null
blob + 770d199fbd9028d8cdf421b8fd776ac5b9aaae4d (mode 644)
--- /dev/null
+++ ex2-28.scm~
+;; Exercise 2.27. Modify your reverse procedure of exercise 2.18 to produce a deep-reverse procedure that takes a list as argument and returns as its value the list with its elements reversed and with all sublists deep-reversed as well. For example,
+
+(define (deep-reverse tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) tree)
+ (else (append
+ (deep-reverse (cdr tree))
+ (list (deep-reverse (car tree)))))))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define x (list (list 1 2) (list 3 4)))
+
+(test-case (reverse x) '((3 4) (1 2)))
+
+(test-case (deep-reverse x) '((4 3) (2 1)))
blob - /dev/null
blob + e7be1fc8d156a4fb44e0f30c46d67669fc109fc5 (mode 644)
--- /dev/null
+++ ex2-29.lisp
+(defun make-mobile (left right)
+ (list left right))
+(defun left-branch (mobile)
+ (first mobile))
+(defun right-branch (mobile)
+ (second mobile))
+(defun make-branch (len structure)
+ (list len structure))
+(defun branch-len (branch)
+ (first branch))
+(defun branch-structure (branch)
+ (second branch))
+
+(defun structure-is-weight? (structure)
+ (atom structure))
+(defun weight-of-branch (branch)
+ (let ((struct (branch-structure branch)))
+ (if (structure-is-weight? struct)
+ struct
+ (weight-of-mobile struct))))
+(defun weight-of-mobile (mobile)
+ (+ (weight-of-branch (left-branch mobile))
+ (weight-of-branch (right-branch mobile))))
+(defun torque-of-branch (branch)
+ (* (branch-len branch)
+ (weight-of-branch branch)))
+(defun branch-balanced? (branch)
+ "A branch is balanced either when it has a structure
+ that's a simple weight, or when the structure is
+ a balanced mobile"
+ (let ((struct (branch-structure branch)))
+ (or
+ (structure-is-weight? struct)
+ (mobile-balanced? struct))))
+(defun mobile-balanced? (mobile)
+ (let ((lb (left-branch mobile))
+ (rb (right-branch mobile)))
+ (and
+ (= (torque-of-branch lb)
+ (torque-of-branch rb))
+ (branch-balanced? lb)
+ (branch-balanced? rb))))
+
blob - /dev/null
blob + dc22ddd0091432ea7ca37b0232bff2364fec1d12 (mode 644)
--- /dev/null
+++ ex2-29.lisp~
+(defun make-mobile (left right)
+ (list left right))
+(defun left-branch (mobile)
+ (first mobile))
+(defun right-branch (mobile)
+ (second mobile))
+(defun make-branch (len structure)
+ (list len structure))
+(defun branch-len (branch)
+ (first branch))
+(defun branch-structure (branch)
+ (second branch))
+
+(defun structure-is-weight? (structure)
+ (atom structure))
+(defun weight-of-branch 9branch)
+(let
blob - /dev/null
blob + a7a71ba3cdc7e88d69ab36242b8bca1f6c480564 (mode 644)
--- /dev/null
+++ ex2-29.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.29. A binary mobile consists of two branches, a left branch and a right branch. Each branch is a rod of a certain length, from which hangs either a weight or another binary mobile. We can represent a binary mobile using compound data by constructing it from two branches (for example, using list):
+
+;; A branch is constructed from a length (which must be a number) together with a structure, which may be either a number (representing a simple weight) or another mobile:
+
+;; a. Write the corresponding selectors left-branch and right-branch, which return the branches of a mobile, and branch-length and branch-structure, which return the components of a branch.
+
+;; b. Using your selectors, define a procedure total-weight that returns the total weight of a mobile.
+
+;; c. A mobile is said to be balanced if the torque applied by its top-left branch is equal to that applied by its top-right branch (that is, if the length of the left rod multiplied by the weight hanging from that rod is equal to the corresponding product for the right side) and if each of the submobiles hanging off its branches is balanced. Design a predicate that tests whether a binary mobile is balanced.
+
+(define (make-mobile left right)
+ (list left right))
+(define (make-branch length structure)
+ (list length structure))
+(define (left-branch mobile)
+ (car mobile))
+(define (right-branch mobile)
+ (cadr mobile))
+(define (branch-length branch)
+ (car branch))
+(define (branch-structure branch)
+ (cadr branch))
+(define (weight? mobile)
+ (not (pair? mobile)))
+(define (total-weight mobile)
+ (if (weight? mobile)
+ mobile
+ (+ (total-weight (branch-structure (left-branch mobile)))
+ (total-weight (branch-structure (right-branch mobile))))))
+
+(define m1 (make-mobile (make-branch 4 5) (make-branch 10 3)))
+(define m2 (make-mobile (make-branch 2 3) (make-branch 3 4)))
+(define m3 (make-mobile (make-branch 4 m1) (make-branch 5 m1)))
+(define m4 (make-mobile (make-branch 7 m3) (make-branch 15 m2)))
+(define m5 (make-mobile (make-branch 1 m4) (make-branch 3 m3)))
+
+;; (test-case (total-weight 4) 4)
+;; (test-case (total-weight m1) 8)
+;; (test-case (total-weight m2) 7)
+;; (test-case (total-weight m3) 16)
+;; (test-case (total-weight m4) 23)
+;; (test-case (total-weight m5) 39)
+
+(define (balanced? mobile)
+ (if (weight? mobile)
+ #t
+ (let* ((lb (left-branch mobile))
+ (rb (right-branch mobile))
+ (ls (branch-structure lb))
+ (rs (branch-structure rb)))
+ (and
+ (balanced? ls)
+ (balanced? rs)
+ (= (* (branch-length lb)
+ (total-weight ls))
+ (* (branch-length rb)
+ (total-weight rs)))))))
+
+(define m6 (make-mobile (make-branch 6 6) (make-branch 9 4))) ;; weight 10
+(define m7 (make-mobile (make-branch 4 5) (make-branch 10 2))) ;; weight 7
+(define m8 (make-mobile (make-branch 5 m6) (make-branch 2 25))) ;; wgt 35
+(define m9 (make-mobile (make-branch 2 m8) (make-branch 10 m7))) ;; wgt 42
+(define m10 (make-mobile (make-branch 1 m9) (make-branch 6 m7))) ;; wgt 49
+
+(test-case (balanced? m1) #f)
+(test-case (balanced? m2) #f)
+(test-case (balanced? m3) #f)
+(test-case (balanced? m4) #f)
+(test-case (balanced? m5) #f)
+(test-case (balanced? m6) #t)
+(test-case (balanced? m7) #t)
+(test-case (balanced? m8) #t)
+(test-case (balanced? m9) #t)
+(test-case (balanced? m10) #t)
+
+;; d. Suppose we change the representation of mobiles so that the constructors are
+
+(define (make-mobile left right)
+ (cons left right))
+(define (make-branch length structure)
+ (cons length structure))
+
+;; How much do you need to change your programs to convert to the new representation?
+
+;; Just need to change these 4:
+
+(define (left-branch mobile)
+ (car mobile))
+(define (right-branch mobile)
+ (cdr mobile))
+(define (branch-length branch)
+ (car branch))
+(define (branch-structure branch)
+ (cdr branch))
blob - /dev/null
blob + bb10063bd811d7ba7ccf9091aff685ace38d80a1 (mode 644)
--- /dev/null
+++ ex2-29.scm~
+;; Exercise 2.29. A binary mobile consists of two branches, a left branch and a right branch. Each branch is a rod of a certain length, from which hangs either a weight or another binary mobile. We can represent a binary mobile using compound data by constructing it from two branches (for example, using list):
+
+(define (make-mobile left right)
+ (list left right))
+
+;; A branch is constructed from a length (which must be a number) together with a structure, which may be either a number (representing a simple weight) or another mobile:
+
+(define (make-branch length structure)
+ (list length structure))
+
+;; a. Write the corresponding selectors left-branch and right-branch, which return the branches of a mobile, and branch-length and branch-structure, which return the components of a branch.
+
+;; b. Using your selectors, define a procedure total-weight that returns the total weight of a mobile.
+
+;; c. A mobile is said to be balanced if the torque applied by its top-left branch is equal to that applied by its top-right branch (that is, if the length of the left rod multiplied by the weight hanging from that rod is equal to the corresponding product for the right side) and if each of the submobiles hanging off its branches is balanced. Design a predicate that tests whether a binary mobile is balanced.
+
+;; d. Suppose we change the representation of mobiles so that the constructors are
+
+(define (make-mobile left right)
+ (cons left right))
+(define (make-branch length structure)
+ (cons length structure))
+
+;; How much do you need to change your programs to convert to the new representation?
blob - /dev/null
blob + 234f27f1cae0af810aea60e51d2f89561fd64845 (mode 644)
--- /dev/null
+++ ex2-3.lisp
+(defun rect-perimeter (rect)
+ (+ (* 2 (rect-width rect))
+ (* 2 (rect-height rect))))
+(defun rect-area (rect)
+ (* (rect-width rect)
+ (rect-height rect)))
+
+
+(defun make-rect (p1 p2)
+ (cons p1 p2))
+(defun rect-width (rect)
+ (abs (- (x-point (car rect))
+ (x-point (cdr rect)))))
+(defun rect-height (rect)
+ (abs (- (y-point (car rect))
+ (y-point (cdr rect)))))
+(defun make-rect (p1 p2)
+ (make-segment p1 p2))
+(defun rect-width (rect)
+ (abs (- (x-point (start-segment rect))
+ (x-point (end-segment rect)))))
+(defun rect-height (rect)
+ (abs (- (y-point (start-segment rect))
+ (y-point (end-segment rect)))))
blob - /dev/null
blob + 7825e09cb680c620c5193d9dfbfa4735649a011a (mode 644)
--- /dev/null
+++ ex2-3.lisp~
+(defun rect-perimeter (rect)
+ (+ (* 2 (rect-width rect))
+ (* 2 (rect-height rect))))
+(defun rect-area (rect)
+ (* (rect-width rect)
+ (rect-height rect)))
+
blob - /dev/null
blob + f37f238c408a44aa666aad0a1c45fcbd322cfc33 (mode 644)
--- /dev/null
+++ ex2-3.scm
+(define (make-point x y)
+ (cons x y))
+(define (x-point p)
+ (car p))
+(define (y-point p)
+ (cdr p))
+
+(define (make-segment start end)
+ (cons start end))
+(define (start-segment seg)
+ (car seg))
+(define (end-segment seg)
+ (cdr seg))
+(define (midpoint-segment seg)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (let ((x1 (x-point (start-segment seg)))
+ (x2 (x-point (end-segment seg)))
+ (y1 (y-point (start-segment seg)))
+ (y2 (y-point (end-segment seg))))
+ (make-point (average x1 x2)
+ (average y1 y2))))
+
+(define (print-point p)
+ (newline)
+ (display "(")
+ (display (x-point p))
+ (display ",")
+ (display (y-point p))
+ (display ")"))
+
+(define x1y2 (make-point 1 2))
+(define x-4y-3 (make-point -4 -3))
+(define x1y2tox-4y-3 (make-segment x1y2 x-4y-3))
+(print-point (midpoint-segment x1y2tox-4y-3))
+(display "=(-3/2,-1/2)")
+
+;; Exercise 2.3. Implement a representation for rectangles in a plane. (Hint: You may want to make use of exercise 2.2.) In terms of your constructors and selectors, create procedures that compute the perimeter and the area of a given rectangle. Now implement a different representation for rectangles. Can you design your system with suitable abstraction barriers, so that the same perimeter and area procedures will work using either representation?
+
+;; makes rectangle given 2 points: top-left and bottom-right
+(define (make-rect tl br)
+ (let ((tr (make-point (x-point br) (y-point tl)))
+ (bl (make-point (x-point tl) (y-point br))))
+ (cons (cons tl tr)
+ (cons bl br))))
+(define (top-left rect)
+ (caar rect))
+(define (bot-right rect)
+ (cddr rect))
+(define (top-right rect)
+ (cdar rect))
+(define (bot-left rect)
+ (cadr rect))
+
+(define (width rect)
+ (- (x-point (top-right rect)) (x-point (top-left rect))))
+(define (height rect)
+ (- (y-point (top-left rect)) (y-point (bot-left rect))))
+
+(define (perimeter rect)
+ (+ (* 2 (width rect))
+ (* 2 (height rect))))
+(define (area rect)
+ (* (width rect) (height rect)))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(define tl (make-point 1 6))
+(define br (make-point 10 3))
+(define rect (make-rect tl br))
+(test-case (perimeter rect) 24)
+(test-case (area rect) 27)
+
+;; makes rectangle given top-left corner, width, and height
+(define (make-rect top-left width height)
+ (cons top-left (cons width height)))
+(define (top-left rect)
+ (car rect))
+(define (bot-right rect)
+ (make-rect (+ (x-point (top-left rect))
+ (width rect))
+ (- (y-point (top-left rect))
+ (height rect))))
+(define (top-right rect)
+ (make-rect (+ (x-point (top-left rect))
+ (width rect))
+ (y-point (top-left rect))))
+(define (bot-left rect)
+ (make-rect (x-point (top-left rect))
+ (- (y-point (top-left rect))
+ (height rect))))
+
+(define (width rect)
+ (cadr rect))
+(define (height rect)
+ (cddr rect))
+
+(define rect (make-rect tl 9 3))
+(test-case (perimeter rect) 24)
+(test-case (area rect) 27)
blob - /dev/null
blob + 77fd0e99bceb2dd4de3b3486482fe3406e5cf2bd (mode 644)
--- /dev/null
+++ ex2-3.scm~
+;; Exercise 2.2. Consider the problem of representing line segments in a plane. Each segment is represented as a pair of points: a starting point and an ending point. Define a constructor make-segment and selectors start-segment and end-segment that define the representation of segments in terms of points. Furthermore, a point can be represented as a pair of numbers: the x coordinate and the y coordinate. Accordingly, specify a constructor make-point and selectors x-point and y-point that define this representation. Finally, using your selectors and constructors, define a procedure midpoint-segment that takes a line segment as argument and returns its midpoint (the point whose coordinates are the average of the coordinates of the endpoints). To try your procedures, you'll need a way to print points:
+
+(define (make-point x y)
+ (cons x y))
+(define (x-point p)
+ (car p))
+(define (y-point p)
+ (cdr p))
+
+(define (make-segment start end)
+ (cons start end))
+(define (start-segment seg)
+ (car seg))
+(define (end-segment seg)
+ (cdr seg))
+(define (midpoint-segment seg)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (let ((x1 (x-point (start-segment seg)))
+ (x2 (x-point (end-segment seg)))
+ (y1 (y-point (start-segment seg)))
+ (y2 (y-point (end-segment seg))))
+ (make-point (average x1 x2)
+ (average y1 y2))))
+
+(define (print-point p)
+ (newline)
+ (display "(")
+ (display (x-point p))
+ (display ",")
+ (display (y-point p))
+ (display ")"))
+
+(define x1y2 (make-point 1 2))
+(define x-4y-3 (make-point -4 -3))
+(define x1y2tox-4y-3 (make-segment x1y2 x-4y-3))
+(print-point (midpoint-segment x1y2tox-4y-3))
+(display "=(-3/2,-1/2)")
+
+;; Exercise 2.3. Implement a representation for rectangles in a plane. (Hint: You may want to make use of exercise 2.2.) In terms of your constructors and selectors, create procedures that compute the perimeter and the area of a given rectangle. Now implement a different representation for rectangles. Can you design your system with suitable abstraction barriers, so that the same perimeter and area procedures will work using either representation?
+
+;; makes rectangle given 4 points: top-left, top-right, bottom-left, bottom-right
+;; (define (make-rect tl tr bl br)
+;; (cons (cons tl tr)
+;; (cons bl br)))
+;; (define (top-left rect)
+;; (caar rect))
+;; (define (top-right rect)
+;; (cdar rect))
+;; (define (bot-left rect)
+;; (cadr rect))
+;; (define (bot-right rect)
+;; (cddr rect))
+
+;; makes rectangle given 2 points: top-left and bottom-right
+(define (make-rect tl br)
+ (let ((tr (make-point (x-point br) (y-point tl)))
+ (bl (make-point (x-point tl) (y-point br))))
+ (cons (cons tl tr)
+ (cons bl br))))
+(define (top-left rect)
+ (caar rect))
+(define (bot-right rect)
+ (cddr rect))
+(define (top-right rect)
+ (cdar rect))
+(define (bot-left rect)
+ (cadr rect))
+
+
+
+(define (perimeter rect)
+
blob - /dev/null
blob + f14b7e46f1d8c296e0ff1c88cb4a89e032d1deba (mode 644)
--- /dev/null
+++ ex2-30.lisp
+(defun square-tree-direct (tree)
+ (cond ((null tree) nil)
+ ((not (consp tree)) (square tree))
+ (t (cons (square-tree-direct (car tree))
+ (square-tree-direct (cdr tree))))))
+
+(defun square-tree-map (tree)
+ (mapcar
+ (lambda (subtree)
+ (if (consp subtree)
+ (square-tre-map subtree)
+ (square subtree)))
+ tree))
+
+(defun tree-map (func tree)
+ (mapcar
+ (lambda (subtree)
+ (if (consp subtree)
+ (tree-map func subtree)
+ (funcall func subtree)))
+ tree))
blob - /dev/null
blob + 93373f06135a4218d90c174edd7c98bb449a090f (mode 644)
--- /dev/null
+++ ex2-30.lisp~
+(defun square-tree-direct (tree)
+ (cond ((null tree) nil)
+ ((not (consp tree))
blob - /dev/null
blob + 259310f1b679d6b8e29c696a2af58db170848ec3 (mode 644)
--- /dev/null
+++ ex2-30.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (scale-tree tree factor)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* factor tree))
+ (else (cons (scale-tree (car tree) factor)
+ (scale-tree (cdr tree) factor)))))
+
+(define (scale-tree tree factor)
+ (map (lambda (sub-tree)
+ (if (pair? sub-tree)
+ (scale-tree sub-tree factor)
+ (* factor sub-tree)))
+ tree))
+
+;; Exercise 2.30. Define a procedure square-tree analogous to the square-list procedure of exercise 2.21. That is, square-list should behave as follows:
+
+(define (square-tree tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* tree tree))
+ (else (cons (square-tree (car tree))
+ (square-tree (cdr tree))))))
+
+(test-case (square-tree
+ (list 1
+ (list 2 (list 3 4) 5)
+ (list 6 7)))
+ '(1 (4 (9 16) 25) (36 49)))
+
+;; Define square-tree both directly (i.e., without using any higher-order procedures) and also by using map and recursion.
+
+(define (square-tree-map tree)
+ (map (lambda (sub-tree)
+ (if (pair? sub-tree)
+ (square-tree-map sub-tree)
+ (* sub-tree sub-tree)))
+ tree))
+
+(test-case (square-tree-map
+ (list 1
+ (list 2 (list 3 4) 5)
+ (list 6 7)))
+ '(1 (4 (9 16) 25) (36 49)))
blob - /dev/null
blob + a3782ca66e74392fdae6f46fe59a15d2207cecd9 (mode 644)
--- /dev/null
+++ ex2-30.scm~
+(define (scale-tree tree factor)
+ (cond ((null? tree) nil)
+ ((not (pair? tree)) (* tree factor))
+ (else (cons (scale-tree (car tree) factor)
+ (scale-tree (cdr tree) factor))
blob - /dev/null
blob + f27ee80831261b973a70e7a29d6f1ea5f0326ec8 (mode 644)
--- /dev/null
+++ ex2-31.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (scale-tree tree factor)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* factor tree))
+ (else (cons (scale-tree (car tree) factor)
+ (scale-tree (cdr tree) factor)))))
+
+(define (scale-tree tree factor)
+ (map (lambda (sub-tree)
+ (if (pair? sub-tree)
+ (scale-tree sub-tree factor)
+ (* factor sub-tree)))
+ tree))
+
+(define (square-tree tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* tree tree))
+ (else (cons (square-tree (car tree))
+ (square-tree (cdr tree))))))
+
+;; (test-case (square-tree
+;; (list 1
+;; (list 2 (list 3 4) 5)
+;; (list 6 7)))
+;; '(1 (4 (9 16) 25) (36 49)))
+
+;; (define (square-tree-map tree)
+;; (map (lambda (sub-tree)
+;; (if (pair? sub-tree)
+;; (square-tree-map sub-tree)
+;; (* sub-tree sub-tree)))
+;; tree))
+
+;; (test-case (square-tree-map
+;; (list 1
+;; (list 2 (list 3 4) 5)
+;; (list 6 7)))
+;; '(1 (4 (9 16) 25) (36 49)))
+
+;; Exercise 2.31. Abstract your answer to exercise 2.30 to produce a procedure tree-map with the property that square-tree could be defined as
+
+(define (tree-map proc tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (proc tree))
+ (else (cons (tree-map proc (car tree))
+ (tree-map proc (cdr tree))))))
+
+(define (square-tree-map tree) (tree-map square tree))
+
+(test-case (square-tree-map
+ (list 1
+ (list 2 (list 3 4) 5)
+ (list 6 7)))
+ '(1 (4 (9 16) 25) (36 49)))
+
+
+;; Exercise 2.32. We can represent a set as a list of distinct elements, and we can represent the set of all subsets of the set as a list of lists. For example, if the set is (1 2 3), then the set of all subsets is (() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)). Complete the following definition of a procedure that generates the set of subsets of a set and give a clear explanation of why it works:
+
+(define (subsets s)
+ (if (null? s)
+ (list nil)
+ (let ((rest (subsets (cdr s))))
+ (append rest (map <??> rest)))))
blob - /dev/null
blob + 259310f1b679d6b8e29c696a2af58db170848ec3 (mode 644)
--- /dev/null
+++ ex2-31.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (scale-tree tree factor)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* factor tree))
+ (else (cons (scale-tree (car tree) factor)
+ (scale-tree (cdr tree) factor)))))
+
+(define (scale-tree tree factor)
+ (map (lambda (sub-tree)
+ (if (pair? sub-tree)
+ (scale-tree sub-tree factor)
+ (* factor sub-tree)))
+ tree))
+
+;; Exercise 2.30. Define a procedure square-tree analogous to the square-list procedure of exercise 2.21. That is, square-list should behave as follows:
+
+(define (square-tree tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* tree tree))
+ (else (cons (square-tree (car tree))
+ (square-tree (cdr tree))))))
+
+(test-case (square-tree
+ (list 1
+ (list 2 (list 3 4) 5)
+ (list 6 7)))
+ '(1 (4 (9 16) 25) (36 49)))
+
+;; Define square-tree both directly (i.e., without using any higher-order procedures) and also by using map and recursion.
+
+(define (square-tree-map tree)
+ (map (lambda (sub-tree)
+ (if (pair? sub-tree)
+ (square-tree-map sub-tree)
+ (* sub-tree sub-tree)))
+ tree))
+
+(test-case (square-tree-map
+ (list 1
+ (list 2 (list 3 4) 5)
+ (list 6 7)))
+ '(1 (4 (9 16) 25) (36 49)))
blob - /dev/null
blob + 163245e47bf967fc14ee3108d627f444d4f2784f (mode 644)
--- /dev/null
+++ ex2-32.lisp
+(defun powerset (s)
+ (if (null s)
+ (list nil)
+ (let ((rest (powerset (cdr s))))
+ (append
+ rest
+ (mapcar (lambda (r)
+ (cons (car s) r))
+ rest)))))
blob - /dev/null
blob + c826619bb044ff9d6bc740200c684d7cf1ecb6e5 (mode 644)
--- /dev/null
+++ ex2-32.lisp~
+(defun powerset (s)
+ (if (null s)
+ (list nil)
+ (let ((rest (powerset (cdr s))))
blob - /dev/null
blob + 51111e76430cdf8d1e8899259f08f89767817885 (mode 644)
--- /dev/null
+++ ex2-32.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.32. We can represent a set as a list of distinct elements, and we can represent the set of all subsets of the set as a list of lists. For example, if the set is (1 2 3), then the set of all subsets is (() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)). Complete the following definition of a procedure that generates the set of subsets of a set and give a clear explanation of why it works:
+
+(define (subsets s)
+ (if (null? s)
+ '(())
+ (let ((rest (subsets (cdr s))))
+ (append rest
+ (map (lambda (subset)
+ (cons (car s) subset))
+ rest)))))
+
+(test-case (subsets '(1 2 3)) '(() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)))
+
+;; what we're doing here is breaking down the problem from originally trying
+;; to find all the subsets of S to instead finding the subsets
+;; of all but the first number
+;; we then take this and add it to all the subsets without the first number
+;; but now with the first number put in the front
+
blob - /dev/null
blob + f27ee80831261b973a70e7a29d6f1ea5f0326ec8 (mode 644)
--- /dev/null
+++ ex2-32.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (scale-tree tree factor)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* factor tree))
+ (else (cons (scale-tree (car tree) factor)
+ (scale-tree (cdr tree) factor)))))
+
+(define (scale-tree tree factor)
+ (map (lambda (sub-tree)
+ (if (pair? sub-tree)
+ (scale-tree sub-tree factor)
+ (* factor sub-tree)))
+ tree))
+
+(define (square-tree tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (* tree tree))
+ (else (cons (square-tree (car tree))
+ (square-tree (cdr tree))))))
+
+;; (test-case (square-tree
+;; (list 1
+;; (list 2 (list 3 4) 5)
+;; (list 6 7)))
+;; '(1 (4 (9 16) 25) (36 49)))
+
+;; (define (square-tree-map tree)
+;; (map (lambda (sub-tree)
+;; (if (pair? sub-tree)
+;; (square-tree-map sub-tree)
+;; (* sub-tree sub-tree)))
+;; tree))
+
+;; (test-case (square-tree-map
+;; (list 1
+;; (list 2 (list 3 4) 5)
+;; (list 6 7)))
+;; '(1 (4 (9 16) 25) (36 49)))
+
+;; Exercise 2.31. Abstract your answer to exercise 2.30 to produce a procedure tree-map with the property that square-tree could be defined as
+
+(define (tree-map proc tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (proc tree))
+ (else (cons (tree-map proc (car tree))
+ (tree-map proc (cdr tree))))))
+
+(define (square-tree-map tree) (tree-map square tree))
+
+(test-case (square-tree-map
+ (list 1
+ (list 2 (list 3 4) 5)
+ (list 6 7)))
+ '(1 (4 (9 16) 25) (36 49)))
+
+
+;; Exercise 2.32. We can represent a set as a list of distinct elements, and we can represent the set of all subsets of the set as a list of lists. For example, if the set is (1 2 3), then the set of all subsets is (() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)). Complete the following definition of a procedure that generates the set of subsets of a set and give a clear explanation of why it works:
+
+(define (subsets s)
+ (if (null? s)
+ (list nil)
+ (let ((rest (subsets (cdr s))))
+ (append rest (map <??> rest)))))
blob - /dev/null
blob + 9bfa1e6fdb3756a6df24e2319e2953cf07e046b3 (mode 644)
--- /dev/null
+++ ex2-33.lisp
+(defun my-map (p sequence)
+ (accumulate
+ (lambda (x y)
+ (cons (funcall p x) y))
+ nil
+ sequence))
blob - /dev/null
blob + f5990955e9a1f42e6b01f62d26203ef71fe31df8 (mode 644)
--- /dev/null
+++ ex2-33.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (filter predicate sequence)
+ (cond ((null? sequence) '())
+ ((predicate (car sequence))
+ (cons (car sequence)
+ (filter predicate (cdr sequence))))
+ (else (filter predicate (cdr sequence)))))
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+(define (enumerate-interval low high)
+ (if (low > high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+(define (enumerate-tree tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (list tree))
+ (else (append (enumerate-tree (car tree))
+ (enumerate-tree (cdr tree))))))
+
+;; Exercise 2.33. Fill in the missing expressions to complete the following definitions of some basic list-manipulation operations as accumulations:
+
+(define (map p sequence)
+ (accumulate (lambda (x y)
+ (cons (p x) y))
+ '()
+ sequence))
+
+(test-case (map square '()) '())
+(test-case (map square '(1)) '(1))
+(test-case (map square '(1 2 3 4 5)) '(1 4 9 16 25))
+
+(define (append seq1 seq2)
+ (accumulate cons
+ seq2
+ seq1))
+
+(test-case (append '() '()) '())
+(test-case (append '(1 2 3) '()) '(1 2 3))
+(test-case (append '() '(4 5 6)) '(4 5 6))
+(test-case (append '(1 2 3) '(4 5 6)) '(1 2 3 4 5 6))
+(test-case (append '((1 (2)) 3) '((4 ((5)) 6))) '((1 (2)) 3 (4 ((5)) 6)))
+
+(define (length sequence)
+ (accumulate (lambda (first accum)
+ (1+ accum))
+ 0
+ sequence))
+
+(test-case (length '()) 0)
+(test-case (length '(1 2 3)) 3)
+(test-case (length '((1 (2)) 3 (4 ((5)) 6))) 3)
blob - /dev/null
blob + b39155e64261bdca59cbd2f977b3505baaa6f171 (mode 644)
--- /dev/null
+++ ex2-33.scm~
+(define (sum-odd-squares tree)
+ (cond ((null? tree) 0)
+ ((not (pair? tree))
+ (if (odd? tree) (square tree) 0))
+ (else (+ (sum-odd-squares (car tree))
+ (sum-odd-squares (cdr tree))))))
+
+(define (even-fibs n)
+ (define (next k)
+ (if (> k n)
+ '()
+ (let ((f (fib k)))
+ (if (even? f)
+ (cons f (next (1+ k)))
+ (next (1+ k))))))
+ (next 0))
+
+(map square (list 1 2 3 4 5))
+
+(define (filter predicate sequence)
+ (cond ((null? sequence) '())
+ ((predicate (car sequence))
+ (cons (car sequence)
+ (filter predicate (cdr sequence))))
+ (else (filter predicate (cdr sequence)))))
+
+(filter odd? (list 1 2 3 4 5))
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+(accumulate + 0 (list 1 2 3 4 5))
+(accumulate * 1 (list 1 2 3 4 5))
+(accumulate cons nil (list 1 2 3 4 5))
+
+(define (enumerate-interval low high)
+ (if (low > high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+(define (enumerate-tree tree)
+ (cond ((null? tree) '())
+ ((not (pair? tree)) (list tree))
+ (else (append (enumerate-tree (car tree))
+ (enumerate-tree (cdr tree))))))
+(enumerate-tree (list 1 (list 2 (list 3 4)) 5))
+
+(define (sum-odd-squares tree)
+ (accumulate +
+ 0
+ (map square
+ (filter odd?
+ (enumerate-tree tree)))))
+(define (even-fibs n)
+ (accumulate cons
+ nil
+ (filter even?
+ (map fib
+ (enumerate-interval 0 n)))))
blob - /dev/null
blob + 7d4c0140643c714cf9c2018428019fbd419e1c1d (mode 644)
--- /dev/null
+++ ex2-34.lisp
+(defun horner-eval (x coeffs)
+ (accumulate
+ (lambda (this-coeff higher-terms)
+ (+ (* x higher-terms) this-coeff))
+ 0
+ coeffs))
blob - /dev/null
blob + 434e0f2323dead698f5db4fea97c302d990c539d (mode 644)
--- /dev/null
+++ ex2-34.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; (+ (* 2 1)
+;; 0)
+;; (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5)
+;; (+ (* 2 (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5))
+;; 0)
+;; (+ (* 2 (+ (* 2 (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5))
+;; 0))
+;; 3)
+;; (+ (* 2 (+ (* 2 (+ (* 2 (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5))
+;; 0))
+;; 3))
+;; 1)
+
+;; the pattern sort of looks like this in pseudo-code
+;; (+ (* 2 (horner-eval 2 (cdr coefficient-sequence)))
+;; (car coefficient-sequence))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (horner-eval x coefficient-sequence)
+ (accumulate (lambda (coefficient remaining-horner)
+ (+ coefficient
+ (* x remaining-horner)))
+ 0
+ coefficient-sequence))
+
+(test-case (horner-eval 0 '()) 0)
+(test-case (horner-eval 10 '()) 0)
+(test-case (horner-eval 0 '(1)) 1)
+(test-case (horner-eval 2 '(1 3 0 5 0 1)) 79)
+(test-case (horner-eval -1 '(2 4 1 1 8 3)) 3)
+(test-case (horner-eval 1.23 '(3 5 2 9 4)) 38.079068639999996)
+
blob - /dev/null
blob + a825b510010bbbe14243492e7b7993373599cadd (mode 644)
--- /dev/null
+++ ex2-34.scm~
+(define (horner-eval x coefficient-sequence)
blob - /dev/null
blob + d6dbae243ab808c1e9317ada91efc5d4d860984b (mode 644)
--- /dev/null
+++ ex2-35.lisp
+(defun count-leaves (tree)
+ (accumulate
+ (lambda (x y)
+ (+ y
+ (if (consp x)
+ (count-leaves x)
+ 1)))
+ 0
+ tree))
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 9639ea0c3f7933d11c3e5511bca3f6f858f6134e (mode 644)
--- /dev/null
+++ ex2-35.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (horner-eval x coefficient-sequence)
+ (accumulate (lambda (coefficient remaining-horner)
+ (+ coefficient
+ (* x remaining-horner)))
+ 0
+ coefficient-sequence))
+
+;; (test-case (horner-eval 0 '()) 0)
+;; (test-case (horner-eval 10 '()) 0)
+;; (test-case (horner-eval 0 '(1)) 1)
+;; (test-case (horner-eval 2 '(1 3 0 5 0 1)) 79)
+;; (test-case (horner-eval -1 '(2 4 1 1 8 3)) 3)
+;; (test-case (horner-eval 1.23 '(3 5 2 9 4)) 38.079068639999996)
+
+;; Exercise 2.35. Redefine count-leaves from section 2.2.2 as an accumulation:
+
+(define (count-leaves t)
+ (accumulate + 0 (map (lambda (subtree)
+ (cond ((null? subtree) 0)
+ ((not (pair? subtree)) 1)
+ (else (count-leaves subtree))))
+ t)))
+
+(test-case (count-leaves '()) 0)
+(test-case (count-leaves '(((())) () (() (())))) 0)
+(test-case (count-leaves '(2 3 0 9 8)) 5)
+(test-case (count-leaves '((2) (1 (2 5 (8 (9) 3) 2)) 4)) 9)
blob - /dev/null
blob + 434e0f2323dead698f5db4fea97c302d990c539d (mode 644)
--- /dev/null
+++ ex2-35.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; (+ (* 2 1)
+;; 0)
+;; (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5)
+;; (+ (* 2 (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5))
+;; 0)
+;; (+ (* 2 (+ (* 2 (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5))
+;; 0))
+;; 3)
+;; (+ (* 2 (+ (* 2 (+ (* 2 (+ (* 2 (+ (* 2 1)
+;; 0))
+;; 5))
+;; 0))
+;; 3))
+;; 1)
+
+;; the pattern sort of looks like this in pseudo-code
+;; (+ (* 2 (horner-eval 2 (cdr coefficient-sequence)))
+;; (car coefficient-sequence))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (horner-eval x coefficient-sequence)
+ (accumulate (lambda (coefficient remaining-horner)
+ (+ coefficient
+ (* x remaining-horner)))
+ 0
+ coefficient-sequence))
+
+(test-case (horner-eval 0 '()) 0)
+(test-case (horner-eval 10 '()) 0)
+(test-case (horner-eval 0 '(1)) 1)
+(test-case (horner-eval 2 '(1 3 0 5 0 1)) 79)
+(test-case (horner-eval -1 '(2 4 1 1 8 3)) 3)
+(test-case (horner-eval 1.23 '(3 5 2 9 4)) 38.079068639999996)
+
blob - /dev/null
blob + cbf87a2f2259d646d5f72cb57b4d1530276bc7b1 (mode 644)
--- /dev/null
+++ ex2-35b.scm
+(define (count-leaves t)
+ (accumulate + 0 (map (lambda (x) 1)
+ (enumerate-tree t))))
blob - /dev/null
blob + eb52c35a60e7188f3859806d6f912212dccd8045 (mode 644)
--- /dev/null
+++ ex2-36.lisp
+(defun accumulate-n (op init seqs)
+ (if (null (car seqs))
+ nil
+ (cons (accumulate op init (mapcar #'car seqs))
+ (accumulate-n op init (mapcar #'cdr seqs)))))
blob - /dev/null
blob + 62a3b2721e6826c826c61b409cbc8b358238c365 (mode 644)
--- /dev/null
+++ ex2-36.lisp~
+(defun accumulate-n (op init seqs)
+ (if (null (car seqs))
+ nil
+ (cons (accumulate op init (mapcar #'car seqs
blob - /dev/null
blob + 2de1ccb6914ef9a38ee91bdd2e89e67c32f2a0f8 (mode 644)
--- /dev/null
+++ ex2-36.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+;; Exercise 2.36. The procedure accumulate-n is similar to accumulate except that it takes as its third argument a sequence of sequences, which are all assumed to have the same number of elements. It applies the designated accumulation procedure to combine all the first elements of the sequences, all the second elements of the sequences, and so on, and returns a sequence of the results. For instance, if s is a sequence containing four sequences, ((1 2 3) (4 5 6) (7 8 9) (10 11 12)), then the value of (accumulate-n + 0 s) should be the sequence (22 26 30). Fill in the missing expressions in the following definition of accumulate-n:
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ '()
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+(test-case (accumulate-n + 0 '((1 2 3) (4 5 6) (7 8 9) (10 11 12))) '(22 26 30))
+(test-case (accumulate-n + 0 '(() () ())) '())
+;; (test-case (accumulate-n + 0 '()) (error "Trying to car empty list"))
+
blob - /dev/null
blob + a9f52ba493339e32fe08b64cd1c9980e2df91648 (mode 644)
--- /dev/null
+++ ex2-36.scm~
+;; Exercise 2.36. The procedure accumulate-n is similar to accumulate except that it takes as its third argument a sequence of sequences, which are all assumed to have the same number of elements. It applies the designated accumulation procedure to combine all the first elements of the sequences, all the second elements of the sequences, and so on, and returns a sequence of the results. For instance, if s is a sequence containing four sequences, ((1 2 3) (4 5 6) (7 8 9) (10 11 12)), then the value of (accumulate-n + 0 s) should be the sequence (22 26 30). Fill in the missing expressions in the following definition of accumulate-n:
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ nil
+ (cons (accumulate op init <??>)
+ (accumulate-n op init <??>))))
blob - /dev/null
blob + 4558d901835276a9f9390ef9e18a480b3d522006 (mode 644)
--- /dev/null
+++ ex2-37.lisp
+(defun dot-product (v w)
+ (accumulate #'+ 0 (mapcar #'* v w)))
+(defun matrix-*-vector (m v)
+ (mapcar
+ (lambda (row)
+ (dot-product row v))
+ m))
+(defun transpose (m)
+ (accumulate-n #'cons nil m))
+(defun matrix-*-matrix (m n)
+ (let ((n-t (transpose n)))
+ (mapcar (lambda (row)
+ (matrix-*-vector n-t row))
+ m)))
blob - /dev/null
blob + 8ba702d4e18e92ec06c4e97c5e1b7608ad5ab1a6 (mode 644)
--- /dev/null
+++ ex2-37.lisp~
+(defun dot-product (v w)
+ (accumulate #'+ 0 (mapcar #'* v w)))
+(defun matrix-*-vector (m v)
+ (mapcar
+ (lambda (row)
+ (dot-product row v))
+ m))
blob - /dev/null
blob + 8e4e1b3c24beee2ac46f403bfe1572b158df1b87 (mode 644)
--- /dev/null
+++ ex2-37.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ '()
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+
+(define (dot-product v w)
+ (accumulate + 0 (map * v w)))
+
+(define (matrix-*-vector m v)
+ (map (lambda (row)
+ (dot-product row v))
+ m))
+
+(define (transpose mat)
+ (accumulate-n cons '() mat))
+
+(define (matrix-*-matrix m n)
+ (let ((cols (transpose n)))
+ (map (lambda (m-row)
+ (matrix-*-vector cols m-row))
+ m)))
+
+(define m1 '((1 2 3) (4 5 6) (7 8 9)))
+(define m2 '((3 1 9) (3 -2 -4) (7 0 5)))
+(define m3 '((30 36 42) (66 81 96) (102 126 150)))
+(define m4 '((3 1 9 -5 -2 1)
+ (3 -2 -4 0 4 8)
+ (7 0 5 2 3 6)))
+(define m5 '((1 5 4)
+ (2 -1 -3)
+ (0 5 0)
+ (-4 0 8)
+ (5 -1 -2)
+ (-3 -2 6)))
+(define m6 '((12 59 -21)
+ (-5 -23 58)
+ (-4 45 74)))
+(define m7 '((1 2 0 -4 5 -3)
+ (5 -1 5 0 -1 -2)
+ (4 -3 0 8 -2 6)))
+(define m8 '((3 3 7)
+ (1 -2 0)
+ (9 -4 5)
+ (-5 0 2)
+ (-2 4 3)
+ (1 8 6)))
+(define v1 '(1 2 3))
+(define v2 '(14 32 50))
+(define v3 '(2 -1 4))
+(define v4 '(41 -8 34))
+
+(test-case (matrix-*-vector m1 v1) v2)
+(test-case (matrix-*-vector m2 v3) v4)
+
+
+(test-case (transpose m5) m7)
+(test-case (transpose m4) m8)
+
+(test-case (matrix-*-matrix m1 m1) m3)
+(test-case (matrix-*-matrix m4 m5) m6)
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + fe8be662ea502dac45ca46ffb5b78989043a96c9 (mode 644)
--- /dev/null
+++ ex2-38.lisp
+(defun fold-right (op init seq)
+ (if (null seq)
+ init
+ (funcall op
+ (car seq)
+ (fold-right op init (cdr seq)))))
+(defun fold-left (op init seq)
+ (labels (
+ (iter (result rest)
+ (if (null rest)
+ result
+ (iter (funcall op result (car rest))
+ (cdr rest)))))
+ (iter init seq)))
+(fold-right #'* 1 '(1 2 3 4 5))
+(fold-left #'* 1 '(1 2 3 4 5))
blob - /dev/null
blob + 8cc7264175d8cac0041ca018845dc44931eceb49 (mode 644)
--- /dev/null
+++ ex2-38.lisp~
+(defun fold-right (op init seq)
+ (if (null seq)
+ init
+ (funcall op
+ (car seq)
+ (fold-right op init (cdr seq)))))
+(defun fold-left (op init seq)
+ (labels (
+ (iter (result rest)
+ (if (null rest)
+ result
+ (iter (funcall op result (car rest))
+ (cdr rest)))))
+ (iter init seq)))
blob - /dev/null
blob + a3451b45155a343ae430a42e41e4135477b0575c (mode 644)
--- /dev/null
+++ ex2-38.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ '()
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+
+;; Exercise 2.38. The accumulate procedure is also known as fold-right, because it combines the first element of the sequence with the result of combining all the elements to the right. There is also a fold-left, which is similar to fold-right, except that it combines elements working in the opposite direction:
+
+(define (fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (car rest))
+ (cdr rest))))
+ (iter initial sequence))
+
+;; What are the values of
+;;(/ 1 (/ 2 (/ 3 1)))
+(test-case (fold-right / 1 (list 1 2 3)) 3/2)
+;;(/ (/ (/ 1 1) 2) 3)
+(test-case (fold-left / 1 (list 1 2 3)) 1/6)
+;;(list 1 (list 2 (list 3 '())))
+(test-case (fold-right list '() (list 1 2 3)) '(1 (2 (3 ()))))
+;;(list (list (list nil 1) 2) 3)
+(test-case (fold-left list '() (list 1 2 3)) '(((() 1) 2) 3))
+
+;; Give a property that op should satisfy to guarantee that fold-right and fold-left will produce the same values for any sequence.
+
+;; we need both associativity and commutativity
+;; associativity
+;; (op a (op b c)) = (op (op a b) c)
+;; commutativity
+;; (op a b) = (op b a)
+
+;; '(a b c)
+;; fold-right
+;; (op a (op b (op c initial)))
+;; fold-left
+;; (op (op (op initial a) b) c)
+;; associativity
+;; (op (op initial (op a b)) c)
+;; commutativity
+;; (op (op (op a b) initial) c)
+;; associativity
+;; (op (op a (op b initial)) c)
+;; associativity
+;; (op a (op (op b initial) c))
+;; associativity
+;; (op a (op b (op initial c)))
+;; commutativity
+;; (op a (op b (op c initial)))
+
+
+
blob - /dev/null
blob + 8e4e1b3c24beee2ac46f403bfe1572b158df1b87 (mode 644)
--- /dev/null
+++ ex2-38.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ '()
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+
+(define (dot-product v w)
+ (accumulate + 0 (map * v w)))
+
+(define (matrix-*-vector m v)
+ (map (lambda (row)
+ (dot-product row v))
+ m))
+
+(define (transpose mat)
+ (accumulate-n cons '() mat))
+
+(define (matrix-*-matrix m n)
+ (let ((cols (transpose n)))
+ (map (lambda (m-row)
+ (matrix-*-vector cols m-row))
+ m)))
+
+(define m1 '((1 2 3) (4 5 6) (7 8 9)))
+(define m2 '((3 1 9) (3 -2 -4) (7 0 5)))
+(define m3 '((30 36 42) (66 81 96) (102 126 150)))
+(define m4 '((3 1 9 -5 -2 1)
+ (3 -2 -4 0 4 8)
+ (7 0 5 2 3 6)))
+(define m5 '((1 5 4)
+ (2 -1 -3)
+ (0 5 0)
+ (-4 0 8)
+ (5 -1 -2)
+ (-3 -2 6)))
+(define m6 '((12 59 -21)
+ (-5 -23 58)
+ (-4 45 74)))
+(define m7 '((1 2 0 -4 5 -3)
+ (5 -1 5 0 -1 -2)
+ (4 -3 0 8 -2 6)))
+(define m8 '((3 3 7)
+ (1 -2 0)
+ (9 -4 5)
+ (-5 0 2)
+ (-2 4 3)
+ (1 8 6)))
+(define v1 '(1 2 3))
+(define v2 '(14 32 50))
+(define v3 '(2 -1 4))
+(define v4 '(41 -8 34))
+
+(test-case (matrix-*-vector m1 v1) v2)
+(test-case (matrix-*-vector m2 v3) v4)
+
+
+(test-case (transpose m5) m7)
+(test-case (transpose m4) m8)
+
+(test-case (matrix-*-matrix m1 m1) m3)
+(test-case (matrix-*-matrix m4 m5) m6)
blob - /dev/null
blob + 0593d5bce8106107840a8155791b080d4b4c010e (mode 644)
--- /dev/null
+++ ex2-39.lisp
+(defun reverse-r (seq)
+ (fold-right (lambda (x y)
+ (append y (list x)))
+ nil
+ seq))
+
+(defun reverse-l (seq)
+ (fold-left (lambda (x y)
+ (cons y x))
+ nil
+ seq))
blob - /dev/null
blob + 578c54ae03ffbdf77b82a27b5435d003d0031de1 (mode 644)
--- /dev/null
+++ ex2-39.lisp~
+(defun reverse-r (seq)
+ (fold-right (lambda (x y)
+ (append y (list x)))
+ nil
+ seq))
blob - /dev/null
blob + e5527b13b7e813435e95bac7269fc5a7aa1c18da (mode 644)
--- /dev/null
+++ ex2-39.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.39. Complete the following definitions of reverse (exercise 2.18) in terms of fold-right and fold-left from exercise 2.38:
+
+(define (reverse-right sequence)
+ (fold-right (lambda (x y)
+ (append y
+ (list x)))
+ '()
+ sequence))
+(define (reverse-left sequence)
+ (fold-left (lambda (x y)
+ (cons y x))
+ '()
+ sequence))
+
+;; '(1 2 3 4 5 6)
+;; (iter (op result (car items)) (cdr items))
+(test-case (reverse-right '(1 2 3 4 5 6)) '(6 5 4 3 2 1))
+(test-case (reverse-right '((1 2) (3) (4 (5 6)))) '((4 (5 6)) (3) (1 2)))
+(test-case (reverse-left '(1 2 3 4 5 6)) '(6 5 4 3 2 1))
+(test-case (reverse-left '((1 2) (3) (4 (5 6)))) '((4 (5 6)) (3) (1 2)))
blob - /dev/null
blob + a3451b45155a343ae430a42e41e4135477b0575c (mode 644)
--- /dev/null
+++ ex2-39.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ '()
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+
+;; Exercise 2.38. The accumulate procedure is also known as fold-right, because it combines the first element of the sequence with the result of combining all the elements to the right. There is also a fold-left, which is similar to fold-right, except that it combines elements working in the opposite direction:
+
+(define (fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (car rest))
+ (cdr rest))))
+ (iter initial sequence))
+
+;; What are the values of
+;;(/ 1 (/ 2 (/ 3 1)))
+(test-case (fold-right / 1 (list 1 2 3)) 3/2)
+;;(/ (/ (/ 1 1) 2) 3)
+(test-case (fold-left / 1 (list 1 2 3)) 1/6)
+;;(list 1 (list 2 (list 3 '())))
+(test-case (fold-right list '() (list 1 2 3)) '(1 (2 (3 ()))))
+;;(list (list (list nil 1) 2) 3)
+(test-case (fold-left list '() (list 1 2 3)) '(((() 1) 2) 3))
+
+;; Give a property that op should satisfy to guarantee that fold-right and fold-left will produce the same values for any sequence.
+
+;; we need both associativity and commutativity
+;; associativity
+;; (op a (op b c)) = (op (op a b) c)
+;; commutativity
+;; (op a b) = (op b a)
+
+;; '(a b c)
+;; fold-right
+;; (op a (op b (op c initial)))
+;; fold-left
+;; (op (op (op initial a) b) c)
+;; associativity
+;; (op (op initial (op a b)) c)
+;; commutativity
+;; (op (op (op a b) initial) c)
+;; associativity
+;; (op (op a (op b initial)) c)
+;; associativity
+;; (op a (op (op b initial) c))
+;; associativity
+;; (op a (op b (op initial c)))
+;; commutativity
+;; (op a (op b (op c initial)))
+
+
+
blob - /dev/null
blob + 516f6e606368fccef350effacd6d887361602737 (mode 644)
--- /dev/null
+++ ex2-4.lisp
+(defun my-cons (x y)
+ (lambda (m)
+ (cond ((= m 0) x)
+ ((= m 1) y)
+ (t (error "Argument not 0 or 1 -- CONS ~S~%" m)))))
+(defun my-car (z)
+ (funcall z 0))
+(defun my-cdr (z)
+ (funcall z 1))
+
+(defun my-cons (x y)
+ (lambda (m) (funcall m x y)))
+(defun my-car (z)
+ (funcall z (lambda (p q) p)))
+(defun my-cdr (z)
+ (funcall z (lambda (p q) q)))
blob - /dev/null
blob + dc855047f37e8aab86837aa40d33a184e283a296 (mode 644)
--- /dev/null
+++ ex2-4.lisp~
+(defun my-cons (x y)
+ (lambda (m)
+ (cond ((= m 0) x)
+ ((= m 1) y)
+ (t (error "Argument not 0 or 1 -- CONS ~S~%" m)))))
+(defun my-car (z)
+ (funcall z 0))
+(defun my-cdr (z)
+ (funcall z 1))
+
+(defun
blob - /dev/null
blob + 207934fd7e7ee8a421e49bdf6e15e618a88ae1f1 (mode 644)
--- /dev/null
+++ ex2-4.scm
+(define (cons x y)
+ (lambda (m) (m x y)))
+(define (car z)
+ (z (lambda (p q) p)))
+
+(car (cons x y))
+((lambda (m) (m x y)) (lambda (p q) p))
+((lambda (p q) p) x y)
+x
+;; Check to see that (car (cons x y)) = x
+
+(define (cdr z)
+ (z (lambda (p q) q)))
+(cdr (cons x y))
+((lambda (m) (m x y)) (lambda (p q) q))
+((lambda (p q) q) x y)
+
blob - /dev/null
blob + 8da7a6a19bf7ec648f9ea5c03bb0b04eca7e67b7 (mode 644)
--- /dev/null
+++ ex2-4.scm~
+(make-rat n d)
+
+(define (cons x y)
+ (define (dispatch m)
+ (cond ((= m 0) x)
+ ((= m 1) y)
+ (else (error "Argument not 0 or 1 -- CONS" m)))))
blob - /dev/null
blob + d64c33db3841b87062780b704e949109fbe4825b (mode 644)
--- /dev/null
+++ ex2-40.lisp
+(defun enumerate-interval (low high)
+ (if (> low high)
+ nil
+ (cons low (enumerate-interval (1+ low) high))))
+(defun flatpmap (proc seq)
+ (accumulate #'append nil (mapcar proc seq)))
+(defun sum (lst)
+ (accumulate #'+ 0 lst))
+(defun prime-sum? (pair)
+ (prime? (sum pair)))
+(defun make-pair-sum (pair)
+ (list (car pair) (cadr pair) (sum pair)))
+(defun unique-pairs (n)
+ (flatmap
+ (lambda (i)
+ (mapcar (lambda (j) (list i j))
+ (enumerate-interval 1 (1- i))))
+ (enumerate-interval 1 n)))
+(defun prime-sum-pairs (n)
+ (mapcar
+ #'make-pair-sum
+ (filter #'prime-sum? (unique-pairs n))))
blob - /dev/null
blob + 3d34d67abe34e9dfb77533a4d1ffe7ae0731d509 (mode 644)
--- /dev/null
+++ ex2-40.lisp~
+(defun enumerate-interval (low high)
+ (if (> low high)
+ nil
+ (cons low (enumerate-interval (1+ low) high))))
+(defun flatpmap (proc seq)
+ (accumulate #'append nil (mapcar proc seq)))
+(defun sum (lst)
+ (accumulate #'+ 0 lst))
+(defun prime-sum? (pair)
+ (prime? (sum pair)))
+(defun make-pair-sum (pair)
+ (list (car pair) (cadr pair) (sum pair)))
blob - /dev/null
blob + 65ef1f095f9d4e5a1852f6e1630fa098a166aabf (mode 644)
--- /dev/null
+++ ex2-40.scm
+(define (smallest-divisor n)
+ (find-divisor n 2))
+(define (find-divisor n test-divisor)
+ (cond ((> (square test-divisor) n) n)
+ (( divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+(define (prime? n)
+ (= n (smallest-divisor n)))
+(define (flatmap proc seq)
+ (accumulate append '() (map proc seq)))
+(define (accumulate op initial seq)
+ (if (null? seq)
+ initial
+ (op (car seq)
+ (accumulate op initial (cdr seq)))))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+(define (prime-sum? pair)
+ (prime? (+ (car pair) (cadr pair))))
+(define (make-pair-sum pair)
+ (list (car pair) (cadr pair) (+ (car pair) (cadr pair))))
+(define (prime-sum-pairs n)
+ (map make-pair-sum
+ (filter prime-sum?
+ (flatmap
+ (lambda (i)
+ (map
+ (lambda (j)
+ (list i j))
+ (enumerate-interval 1 (- i 1)))
+ (enumerate-interval 1 n))))))
+(define (permutations s)
+ (if (null? s)
+ '(())
+ (flatmap (lambda (x)
+ (map (lambda (p) (cons x p))
+ (permutations (remove x s))))
+ s)))
+(define (remove item sequence)
+ (filter (lambda (x) (not (= x item)))
+ sequence))
+(define (unique-pairs n)
+ (flatmap
+ (lambda (i)
+ (map (lambda (j)
+ (list i j))
+ (enumerate-interval 1 (- i 1))))
+ (enumerate-interval 1 n)))
+(define (prime-sum-pairs n)
+ (map make-pair-sum
+ (filter
+ prime-sum?
+ (unique-pairs n))))
+
+(prime-sum-pairs 10)
blob - /dev/null
blob + f51f776543141bf365b81af53d8e9510ec9acaf8 (mode 644)
--- /dev/null
+++ ex2-40.scm~
+(accumulate append
+ nil
+ (map (lambda (i)
+ (map (lambda (j) (list i j))
+ (enumerate-interval 1 (- i 1))))
+ (enumerate-interval 1 n)))
blob - /dev/null
blob + d163a5f5c5b699695e91aa1e942d78f0f9f82e16 (mode 644)
--- /dev/null
+++ ex2-41.lisp
+(defun unique-triples (n)
+ "Unique triples of numbers <= n"
+ (flatmap
+ (lambda (i)
+ (flatmap
+ (lambda (j)
+ (mapcar
+ (lambda (k) (list i j k))
+ (enumerate-interval 1 (1- j))))
+ (enumerate-interval 1 (1- i))))
+ (enumerate-interval 1 n)))
+
+(defune triples-sum-s (s n)
+ "Triples of numbers <= n summing to s"
+ (filter
+ (lambda (triple)
+ (= (sum triple) s))
+ (unique-triples n)))
blob - /dev/null
blob + 718ac39ca226da40f171afe0b4a57509c599c66f (mode 644)
--- /dev/null
+++ ex2-41.lisp~
+(defun unique-triples (n)
+ "Unique triples of numbers <= n"
+ (flatmap
+ (lambda (i)
+ (flatmap
+ (lambda (j)
+ (mapcar
+ (lambda (k) (list i j k))
+ (enumerate-interval 1 (1- j))))
+ (enumerate-interval 1 (1- i))))
+ (enumerate-interval 1 n)))
+
+(defune triples-sum-s (s n)
+ "Triples
blob - /dev/null
blob + fc17504ae13dfb9f6867a460225752446132bbdf (mode 644)
--- /dev/null
+++ ex2-41.scm
+(define (smallest-divisor n)
+ (find-divisor n 2))
+(define (find-divisor n test-divisor)
+ (cond ((> (square test-divisor) n) n)
+ (( divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+(define (prime? n)
+ (= n (smallest-divisor n)))
+(define (flatmap proc seq)
+ (accumulate append '() (map proc seq)))
+(define (accumulate op initial seq)
+ (if (null? seq)
+ initial
+ (op (car seq)
+ (accumulate op initial (cdr seq)))))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+(define (prime-sum? pair)
+ (prime? (+ (car pair) (cadr pair))))
+(define (make-pair-sum pair)
+ (list (car pair) (cadr pair) (+ (car pair) (cadr pair))))
+(define (prime-sum-pairs n)
+ (map make-pair-sum
+ (filter prime-sum?
+ (flatmap
+ (lambda (i)
+ (map
+ (lambda (j)
+ (list i j))
+ (enumerate-interval 1 (- i 1)))
+ (enumerate-interval 1 n))))))
+(define (permutations s)
+ (if (null? s)
+ '(())
+ (flatmap (lambda (x)
+ (map (lambda (p) (cons x p))
+ (permutations (remove x s))))
+ s)))
+(define (remove item sequence)
+ (filter (lambda (x) (not (= x item)))
+ sequence))
+(define (unique-pairs n)
+ (flatmap
+ (lambda (i)
+ (map (lambda (j)
+ (list i j))
+ (enumerate-interval 1 (- i 1))))
+ (enumerate-interval 1 n)))
+(define (prime-sum-pairs n)
+ (map make-pair-sum
+ (filter
+ prime-sum?
+ (unique-pairs n))))
+
+;; (prime-sum-pairs 10)
+
+;; Exercise 2.41. Write a procedure to find all ordered triples of distinct positive integers i, j, and k less than or equal to a given integer n that sum to a given integer s.
+
+;; 1 <= k < j < i <= n
+(define (triples n sum)
+ (define (triple-sum? lst)
+ (= (+ (car lst)
+ (cadr lst)
+ (caddr lst)) sum))
+ (filter triple-sum?
+ (flatmap (lambda (i)
+ (flatmap (lambda (j)
+ (map (lambda (k)
+ (list i j k))
+ (enumerate-interval 1 (- j 1))))
+ (enumerate-interval 1 (- i 1))))
+ (enumerate-interval 1 n))))
+
+(triples 10 12)
+
blob - /dev/null
blob + 65ef1f095f9d4e5a1852f6e1630fa098a166aabf (mode 644)
--- /dev/null
+++ ex2-41.scm~
+(define (smallest-divisor n)
+ (find-divisor n 2))
+(define (find-divisor n test-divisor)
+ (cond ((> (square test-divisor) n) n)
+ (( divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1)))))
+(define (divides? a b)
+ (= (remainder b a) 0))
+(define (prime? n)
+ (= n (smallest-divisor n)))
+(define (flatmap proc seq)
+ (accumulate append '() (map proc seq)))
+(define (accumulate op initial seq)
+ (if (null? seq)
+ initial
+ (op (car seq)
+ (accumulate op initial (cdr seq)))))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+(define (prime-sum? pair)
+ (prime? (+ (car pair) (cadr pair))))
+(define (make-pair-sum pair)
+ (list (car pair) (cadr pair) (+ (car pair) (cadr pair))))
+(define (prime-sum-pairs n)
+ (map make-pair-sum
+ (filter prime-sum?
+ (flatmap
+ (lambda (i)
+ (map
+ (lambda (j)
+ (list i j))
+ (enumerate-interval 1 (- i 1)))
+ (enumerate-interval 1 n))))))
+(define (permutations s)
+ (if (null? s)
+ '(())
+ (flatmap (lambda (x)
+ (map (lambda (p) (cons x p))
+ (permutations (remove x s))))
+ s)))
+(define (remove item sequence)
+ (filter (lambda (x) (not (= x item)))
+ sequence))
+(define (unique-pairs n)
+ (flatmap
+ (lambda (i)
+ (map (lambda (j)
+ (list i j))
+ (enumerate-interval 1 (- i 1))))
+ (enumerate-interval 1 n)))
+(define (prime-sum-pairs n)
+ (map make-pair-sum
+ (filter
+ prime-sum?
+ (unique-pairs n))))
+
+(prime-sum-pairs 10)
blob - /dev/null
blob + ebe074a283f14ce70f094d0fd856569161955669 (mode 644)
--- /dev/null
+++ ex2-42.lisp
+(defun make-position (row col)
+ (cons row col))
+(defun position-row (pos)
+ (car pos))
+(defun position-col (pos)
+ (cdr pos))
+(defun positions-equal (a b)
+ (equal a b))
+(defvar empty-board '())
+(defun adjoin-position (row col positions)
+ (append positions (list (make-position row col))))
+(defun attacks? (a b)
+ (let ((a-row (position-row a))
+ (a-col (position-col a))
+ (b-row (position-row b))
+ (b-col (position-col b)))
+ (cond
+ ((= a-row b-row) t)
+ ((= a-col b-col) t)
+ ((= (abs (- a-col b-col))
+ (abs (- a-row b-row))) t)
+ (t nil))))
+(defun safe? (k positions)
+ (let ((kth-pos (nth (1- k) positions)))
+ (if (null (find-if
+ (lambda (pos)
+ (and (not (positions-equal kth-pos pos))
+ (attacks? kth-pos pos)))
+ positions))
+ t
+ nil)))
blob - /dev/null
blob + 8ac27d310e198ef36f7fdbfc9315c837893f324b (mode 644)
--- /dev/null
+++ ex2-42.lisp~
+(defun make-position (row col)
+ (cons row col))
+(defun position-row (pos)
+ (car pos))
+(defun position-col (pos)
+ (cdr pos))
+(defun positions-equal (a b)
+ (equal a b))
+(defvar empty-board '())
+(defun adjoin-position (row col positions)
+ (append positions (list (make-position row col))))
+(defun attacks? (a b)
+ (let ((a-row (position-row a))
+ (a-col (position-col a))
+ (b-row (position-row b))
+ (b-col (position-col b)))
+ (cond
+ ((= a-row b-row) t)
+ ((= a-col b-col) t)
+ ((= (abs (- a-col b-col))
+ (abs (- a-row b-row)))
blob - /dev/null
blob + 3ed90f100e832506831ae6bbb495d8e73713d411 (mode 644)
--- /dev/null
+++ ex2-42.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (flatmap proc seq)
+ (fold-right append '() (map proc seq)))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+
+
+(define (queens board-size)
+ (define (queen-cols k)
+ (if (= k 0)
+ (list empty-board)
+ (filter
+ (lambda (positions) (safe? k positions))
+ (flatmap
+ (lambda (rest-of-queens)
+ (map (lambda (new-row)
+ (adjoin-position new-row k rest-of-queens))
+ (enumerate-interval 1 board-size)))
+ (queen-cols (- k 1))))))
+ (queen-cols board-size))
+
+;; 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.
+(define empty-board '())
+
+;; take positions and append new-queen-row in the (new-queen-col - 1)st position in the list
+(define (adjoin-position new-queen-row new-queen-col positions)
+ (append positions
+ (list new-queen-row)))
+
+(define (same-row? row other-positions)
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ other-positions))
+
+
+(define (same-positive-diagonal? row col other-positions)
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + other-positions (enumerate-interval 1 (- col 1)))))
+(define (same-negative-diagonal? row col other-positions)
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - other-positions (enumerate-interval 1 (- col 1)))))
+
+(define (safe? col positions)
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (not (or (same-row? row all-but-last)
+ (same-positive-diagonal? row col all-but-last)
+ (same-negative-diagonal? row col all-but-last)))))
+
+(define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+;; ;;(test-case (exclude-last '()) "error: empty list")
+;; (test-case (exclude-last '(1)) '())
+;; (test-case (exclude-last '(1 2 3 4)) '(1 2 3))
+
+;; (test-case (adjoin-position 1 1 '()) '(1))
+;; (test-case (adjoin-position 2 1 '()) '(2))
+;; (test-case (adjoin-position 3 1 '()) '(3))
+;; (test-case (adjoin-position 4 1 '()) '(4))
+;; (test-case (adjoin-position 1 4 '(2 4 1)) '(2 4 1 1))
+;; (test-case (adjoin-position 2 4 '(2 4 1)) '(2 4 1 2))
+;; (test-case (adjoin-position 3 4 '(2 4 1)) '(2 4 1 3))
+;; (test-case (adjoin-position 4 4 '(2 4 1)) '(2 4 1 4))
+
+;; (test-case (same-row? 1 '()) #f)
+;; (test-case (same-row? 1 '(2 4 1)) #t)
+;; (test-case (same-row? 2 '(2 4 1)) #t)
+;; (test-case (same-row? 3 '(2 4 1)) #f)
+;; (test-case (same-row? 4 '(2 4 1)) #t)
+;; (test-case (same-row? 4 '(2 4 1)) #t)
+;; (test-case (same-row? 1 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 2 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 3 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 4 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 5 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-row? 6 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-row? 8 '(2 4 6 8 3 1)) #t)
+
+
+;; '((2 4 1))
+;; '((1 2 3 4))
+;; '(((2 4 1 1) (2 4 1 2) (2 4 1 3) (2 4 1 4)))
+;; take '(2 4 1) and append new-queen-row in the (new-queen-col - 1)st position in the list
+;; (define (adjoin-position new-queen-row new-queen-col positions)
+
+;; '(2 4 1)
+;;+ '(1 2 3)
+;;==========
+;; '(3 6 4)
+;; (test-case (same-positive-diagonal? 1 1 '()) #f)
+;; (test-case (same-positive-diagonal? 1 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 2 4 '(2 4 1)) #t)
+;; (test-case (same-positive-diagonal? 3 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 4 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 1 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 2 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 3 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 4 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 5 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 6 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 7 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 8 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 1 1 '()) #f)
+;; (test-case (same-negative-diagonal? 1 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 2 4 '(2 4 1)) #t)
+;; (test-case (same-negative-diagonal? 3 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 4 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 1 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 2 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-negative-diagonal? 3 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 4 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 5 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-negative-diagonal? 6 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 7 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 8 7 '(2 4 6 8 3 1)) #t)
+
+;; (test-case (safe? 1 '(1)) #t)
+;; (test-case (safe? 4 '(2 4 1 1)) #f)
+;; (test-case (safe? 4 '(2 4 1 2)) #f)
+;; (test-case (safe? 4 '(2 4 1 3)) #t)
+;; (test-case (safe? 4 '(2 4 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 1)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 2)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 3)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 5)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 6)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 7)) #t)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+;; The ``eight-queens puzzle'' asks how to place eight queens on a chessboard so that no queen is in check from any other (i.e., no two queens are in the same row, column, or diagonal). One way to solve the puzzle is to work across the board, placing a queen in each column. Once we have placed k - 1 queens, we must place the kth queen in a position where it does not check any of the queens already on the board. We can formulate this approach recursively: Assume that we have already generated the sequence of all possible ways to place k - 1 queens in the first k - 1 columns of the board. For each of these ways, generate an extended set of positions by placing a queen in each row of the kth column. Now filter these, keeping only the positions for which the queen in the kth column is safe with respect to the other queens. This produces the sequence of all ways to place k queens in the first k columns. By continuing this process, we will produce not only one solution, but all solutions to the puzzle.
+
+;; We implement this solution as a procedure queens, which returns a sequence of all solutions to the problem of placing n queens on an n× n chessboard. Queens has an internal procedure queen-cols that returns the sequence of all ways to place queens in the first k columns of the board.
+
+
+;; In this procedure rest-of-queens is a way to place k - 1 queens in the first k - 1 columns, and new-row is a proposed row in which to place the queen for the kth column. Complete the program by implementing the representation for sets of board positions, including the procedure adjoin-position, which adjoins a new row-column position to a set of positions, and empty-board, which represents an empty set of positions. You must also write the procedure safe?, which determines for a set of positions, whether the queen in the kth column is safe with respect to the others. (Note that we need only check whether the new queen is safe -- the other queens are already guaranteed safe with respect to each other.)
+
+(queens 8)
blob - /dev/null
blob + 563dc6ff55dfc45b929e641011a0f22bac1fc79a (mode 644)
--- /dev/null
+++ ex2-42.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (flatmap proc seq)
+ (fold-right append '() (map proc seq)))
+
+(define (queens board-size)
+ (define (queen-cols k)
+ (if (= k 0)
+ (list empty-board)
+ (filter
+ (lambda (positions) (safe? k positions))
+ (flatmap
+ (lambda (rest-of-queens)
+ (map (lambda (new-row)
+ (adjoin-position new-row k rest-of-queens))
+ (enumerate-interval 1 board-size)))
+ (queen-cols (- k 1))))))
+ (queen-cols board-size))
+
+;; 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.
+(define empty-board '())
+
+;; take positions and append new-queen-row in the (new-queen-col - 1)st position in the list
+(define (adjoin-position new-queen-row new-queen-col positions)
+ (append positions
+ (list new-queen-row)))
+
+(define (same-row? row other-positions)
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ other-positions))
+
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+
+(define (same-positive-diagonal? row col other-positions)
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + other-positions (enumerate-interval 1 (- col 1)))))
+(define (same-negative-diagonal? row col other-positions)
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - other-positions (enumerate-interval 1 (- col 1)))))
+
+(define (safe? col positions)
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (not (or (same-row? row all-but-last)
+ (same-positive-diagonal? row col all-but-last)
+ (same-negative-diagonal? row col all-but-last)))))
+
+(define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+;; ;;(test-case (exclude-last '()) "error: empty list")
+;; (test-case (exclude-last '(1)) '())
+;; (test-case (exclude-last '(1 2 3 4)) '(1 2 3))
+
+;; (test-case (adjoin-position 1 1 '()) '(1))
+;; (test-case (adjoin-position 2 1 '()) '(2))
+;; (test-case (adjoin-position 3 1 '()) '(3))
+;; (test-case (adjoin-position 4 1 '()) '(4))
+;; (test-case (adjoin-position 1 4 '(2 4 1)) '(2 4 1 1))
+;; (test-case (adjoin-position 2 4 '(2 4 1)) '(2 4 1 2))
+;; (test-case (adjoin-position 3 4 '(2 4 1)) '(2 4 1 3))
+;; (test-case (adjoin-position 4 4 '(2 4 1)) '(2 4 1 4))
+
+;; (test-case (same-row? 1 '()) #f)
+;; (test-case (same-row? 1 '(2 4 1)) #t)
+;; (test-case (same-row? 2 '(2 4 1)) #t)
+;; (test-case (same-row? 3 '(2 4 1)) #f)
+;; (test-case (same-row? 4 '(2 4 1)) #t)
+;; (test-case (same-row? 4 '(2 4 1)) #t)
+;; (test-case (same-row? 1 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 2 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 3 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 4 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 5 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-row? 6 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-row? 8 '(2 4 6 8 3 1)) #t)
+
+
+;; '((2 4 1))
+;; '((1 2 3 4))
+;; '(((2 4 1 1) (2 4 1 2) (2 4 1 3) (2 4 1 4)))
+;; take '(2 4 1) and append new-queen-row in the (new-queen-col - 1)st position in the list
+;; (define (adjoin-position new-queen-row new-queen-col positions)
+
+;; '(2 4 1)
+;;+ '(1 2 3)
+;;==========
+;; '(3 6 4)
+;; (test-case (same-positive-diagonal? 1 1 '()) #f)
+;; (test-case (same-positive-diagonal? 1 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 2 4 '(2 4 1)) #t)
+;; (test-case (same-positive-diagonal? 3 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 4 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 1 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 2 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 3 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 4 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 5 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 6 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 7 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 8 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 1 1 '()) #f)
+;; (test-case (same-negative-diagonal? 1 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 2 4 '(2 4 1)) #t)
+;; (test-case (same-negative-diagonal? 3 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 4 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 1 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 2 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-negative-diagonal? 3 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 4 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 5 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-negative-diagonal? 6 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 7 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 8 7 '(2 4 6 8 3 1)) #t)
+
+;; (test-case (safe? 1 '(1)) #t)
+;; (test-case (safe? 4 '(2 4 1 1)) #f)
+;; (test-case (safe? 4 '(2 4 1 2)) #f)
+;; (test-case (safe? 4 '(2 4 1 3)) #t)
+;; (test-case (safe? 4 '(2 4 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 1)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 2)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 3)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 5)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 6)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 7)) #t)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+;; The ``eight-queens puzzle'' asks how to place eight queens on a chessboard so that no queen is in check from any other (i.e., no two queens are in the same row, column, or diagonal). One way to solve the puzzle is to work across the board, placing a queen in each column. Once we have placed k - 1 queens, we must place the kth queen in a position where it does not check any of the queens already on the board. We can formulate this approach recursively: Assume that we have already generated the sequence of all possible ways to place k - 1 queens in the first k - 1 columns of the board. For each of these ways, generate an extended set of positions by placing a queen in each row of the kth column. Now filter these, keeping only the positions for which the queen in the kth column is safe with respect to the other queens. This produces the sequence of all ways to place k queens in the first k columns. By continuing this process, we will produce not only one solution, but all solutions to the puzzle.
+
+;; We implement this solution as a procedure queens, which returns a sequence of all solutions to the problem of placing n queens on an n× n chessboard. Queens has an internal procedure queen-cols that returns the sequence of all ways to place queens in the first k columns of the board.
+
+
+;; In this procedure rest-of-queens is a way to place k - 1 queens in the first k - 1 columns, and new-row is a proposed row in which to place the queen for the kth column. Complete the program by implementing the representation for sets of board positions, including the procedure adjoin-position, which adjoins a new row-column position to a set of positions, and empty-board, which represents an empty set of positions. You must also write the procedure safe?, which determines for a set of positions, whether the queen in the kth column is safe with respect to the others. (Note that we need only check whether the new queen is safe -- the other queens are already guaranteed safe with respect to each other.)
+
+(queens 8)
blob - /dev/null
blob + 23d0ad751b68477d09dbe9132bf59564e77a6f99 (mode 644)
--- /dev/null
+++ ex2-42b.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (flatmap proc seq)
+ (fold-right append '() (map proc seq)))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+
+
+(define (queens board-size)
+ (define (queen-cols k)
+ (if (= k 0)
+ (list empty-board)
+ (filter
+ (lambda (positions) (safe? k positions))
+ (flatmap
+ (lambda (rest-of-queens)
+ (map (lambda (new-row)
+ (adjoin-position new-row k rest-of-queens))
+ (enumerate-interval 1 board-size)))
+ (queen-cols (- k 1))))))
+ (queen-cols board-size))
+
+;; 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.
+(define empty-board '())
+
+;; take positions and append new-queen-row in the (new-queen-col - 1)st position in the list
+(define (adjoin-position new-queen-row new-queen-col positions)
+ (append positions
+ (list new-queen-row)))
+(define (safe? col positions)
+ (define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (let ((same-row?
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ all-but-last))
+ (same-positive-diagonal?
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + all-but-last (enumerate-interval 1 (- col 1)))))
+ (same-negative-diagonal?
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - all-but-last (enumerate-interval 1 (- col 1))))))
+ (not (or same-row? same-positive-diagonal? same-negative-diagonal?)))))
+
+
+;; (test-case (safe? 1 '(1)) #t)
+;; (test-case (safe? 4 '(2 4 1 1)) #f)
+;; (test-case (safe? 4 '(2 4 1 2)) #f)
+;; (test-case (safe? 4 '(2 4 1 3)) #t)
+;; (test-case (safe? 4 '(2 4 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 1)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 2)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 3)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 5)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 6)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 7)) #t)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+(queens 8)
blob - /dev/null
blob + 3ed90f100e832506831ae6bbb495d8e73713d411 (mode 644)
--- /dev/null
+++ ex2-42b.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (flatmap proc seq)
+ (fold-right append '() (map proc seq)))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+
+
+(define (queens board-size)
+ (define (queen-cols k)
+ (if (= k 0)
+ (list empty-board)
+ (filter
+ (lambda (positions) (safe? k positions))
+ (flatmap
+ (lambda (rest-of-queens)
+ (map (lambda (new-row)
+ (adjoin-position new-row k rest-of-queens))
+ (enumerate-interval 1 board-size)))
+ (queen-cols (- k 1))))))
+ (queen-cols board-size))
+
+;; 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.
+(define empty-board '())
+
+;; take positions and append new-queen-row in the (new-queen-col - 1)st position in the list
+(define (adjoin-position new-queen-row new-queen-col positions)
+ (append positions
+ (list new-queen-row)))
+
+(define (same-row? row other-positions)
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ other-positions))
+
+
+(define (same-positive-diagonal? row col other-positions)
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + other-positions (enumerate-interval 1 (- col 1)))))
+(define (same-negative-diagonal? row col other-positions)
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - other-positions (enumerate-interval 1 (- col 1)))))
+
+(define (safe? col positions)
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (not (or (same-row? row all-but-last)
+ (same-positive-diagonal? row col all-but-last)
+ (same-negative-diagonal? row col all-but-last)))))
+
+(define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+;; ;;(test-case (exclude-last '()) "error: empty list")
+;; (test-case (exclude-last '(1)) '())
+;; (test-case (exclude-last '(1 2 3 4)) '(1 2 3))
+
+;; (test-case (adjoin-position 1 1 '()) '(1))
+;; (test-case (adjoin-position 2 1 '()) '(2))
+;; (test-case (adjoin-position 3 1 '()) '(3))
+;; (test-case (adjoin-position 4 1 '()) '(4))
+;; (test-case (adjoin-position 1 4 '(2 4 1)) '(2 4 1 1))
+;; (test-case (adjoin-position 2 4 '(2 4 1)) '(2 4 1 2))
+;; (test-case (adjoin-position 3 4 '(2 4 1)) '(2 4 1 3))
+;; (test-case (adjoin-position 4 4 '(2 4 1)) '(2 4 1 4))
+
+;; (test-case (same-row? 1 '()) #f)
+;; (test-case (same-row? 1 '(2 4 1)) #t)
+;; (test-case (same-row? 2 '(2 4 1)) #t)
+;; (test-case (same-row? 3 '(2 4 1)) #f)
+;; (test-case (same-row? 4 '(2 4 1)) #t)
+;; (test-case (same-row? 4 '(2 4 1)) #t)
+;; (test-case (same-row? 1 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 2 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 3 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 4 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 5 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-row? 6 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-row? 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-row? 8 '(2 4 6 8 3 1)) #t)
+
+
+;; '((2 4 1))
+;; '((1 2 3 4))
+;; '(((2 4 1 1) (2 4 1 2) (2 4 1 3) (2 4 1 4)))
+;; take '(2 4 1) and append new-queen-row in the (new-queen-col - 1)st position in the list
+;; (define (adjoin-position new-queen-row new-queen-col positions)
+
+;; '(2 4 1)
+;;+ '(1 2 3)
+;;==========
+;; '(3 6 4)
+;; (test-case (same-positive-diagonal? 1 1 '()) #f)
+;; (test-case (same-positive-diagonal? 1 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 2 4 '(2 4 1)) #t)
+;; (test-case (same-positive-diagonal? 3 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 4 4 '(2 4 1)) #f)
+;; (test-case (same-positive-diagonal? 1 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 2 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 3 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 4 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 5 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-positive-diagonal? 6 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 7 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-positive-diagonal? 8 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 1 1 '()) #f)
+;; (test-case (same-negative-diagonal? 1 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 2 4 '(2 4 1)) #t)
+;; (test-case (same-negative-diagonal? 3 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 4 4 '(2 4 1)) #f)
+;; (test-case (same-negative-diagonal? 1 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 2 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-negative-diagonal? 3 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 4 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 5 7 '(2 4 6 8 3 1)) #t)
+;; (test-case (same-negative-diagonal? 6 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 7 7 '(2 4 6 8 3 1)) #f)
+;; (test-case (same-negative-diagonal? 8 7 '(2 4 6 8 3 1)) #t)
+
+;; (test-case (safe? 1 '(1)) #t)
+;; (test-case (safe? 4 '(2 4 1 1)) #f)
+;; (test-case (safe? 4 '(2 4 1 2)) #f)
+;; (test-case (safe? 4 '(2 4 1 3)) #t)
+;; (test-case (safe? 4 '(2 4 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 1)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 2)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 3)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 5)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 6)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 7)) #t)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+;; The ``eight-queens puzzle'' asks how to place eight queens on a chessboard so that no queen is in check from any other (i.e., no two queens are in the same row, column, or diagonal). One way to solve the puzzle is to work across the board, placing a queen in each column. Once we have placed k - 1 queens, we must place the kth queen in a position where it does not check any of the queens already on the board. We can formulate this approach recursively: Assume that we have already generated the sequence of all possible ways to place k - 1 queens in the first k - 1 columns of the board. For each of these ways, generate an extended set of positions by placing a queen in each row of the kth column. Now filter these, keeping only the positions for which the queen in the kth column is safe with respect to the other queens. This produces the sequence of all ways to place k queens in the first k columns. By continuing this process, we will produce not only one solution, but all solutions to the puzzle.
+
+;; We implement this solution as a procedure queens, which returns a sequence of all solutions to the problem of placing n queens on an n× n chessboard. Queens has an internal procedure queen-cols that returns the sequence of all ways to place queens in the first k columns of the board.
+
+
+;; In this procedure rest-of-queens is a way to place k - 1 queens in the first k - 1 columns, and new-row is a proposed row in which to place the queen for the kth column. Complete the program by implementing the representation for sets of board positions, including the procedure adjoin-position, which adjoins a new row-column position to a set of positions, and empty-board, which represents an empty set of positions. You must also write the procedure safe?, which determines for a set of positions, whether the queen in the kth column is safe with respect to the others. (Note that we need only check whether the new queen is safe -- the other queens are already guaranteed safe with respect to each other.)
+
+(queens 8)
blob - /dev/null
blob + ed842a7f272f8e2e30880e913e662188fca5b481 (mode 644)
--- /dev/null
+++ ex2-42c.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (flatmap proc seq)
+ (fold-right append '() (map proc seq)))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+
+(define (queens board-size)
+ (define (queen-cols k)
+ (if (= k 0)
+ (list empty-board)
+ (filter
+ (lambda (positions) (safe? k positions))
+ (flatmap
+ (lambda (rest-of-queens)
+ (map (lambda (new-row)
+ (adjoin-position new-row k rest-of-queens))
+ (enumerate-interval 1 board-size)))
+ (queen-cols (- k 1))))))
+ (queen-cols board-size))
+
+;; For example, '(((2 1) (4 2) (1 3) (3 4))) represents col#1 row#2, col#2 row#4, col#3 row#1, col#4 row#3.
+(define empty-board '())
+
+;; (adjoin-position 1 3 '((2 1) (4 2))) = '((2 1) (4 2) (1 3))
+(define (adjoin-position row col positions)
+ (append positions (list (list row col))))
+
+
+;; not finished
+(define (safe? col positions)
+ (define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (let ((same-row?
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ all-but-last))
+ (same-positive-diagonal?
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + all-but-last (enumerate-interval 1 (- col 1)))))
+ (same-negative-diagonal?
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - all-but-last (enumerate-interval 1 (- col 1))))))
+ (not (or same-row? same-positive-diagonal? same-negative-diagonal?)))))
+
+
+;; (test-case (safe? 1 '(1)) #t)
+;; (test-case (safe? 4 '(2 4 1 1)) #f)
+;; (test-case (safe? 4 '(2 4 1 2)) #f)
+;; (test-case (safe? 4 '(2 4 1 3)) #t)
+;; (test-case (safe? 4 '(2 4 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 1)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 2)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 3)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 5)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 6)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 7)) #t)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+(queens 8)
blob - /dev/null
blob + 23d0ad751b68477d09dbe9132bf59564e77a6f99 (mode 644)
--- /dev/null
+++ ex2-42c.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (flatmap proc seq)
+ (fold-right append '() (map proc seq)))
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (1+ low) high))))
+
+
+(define (queens board-size)
+ (define (queen-cols k)
+ (if (= k 0)
+ (list empty-board)
+ (filter
+ (lambda (positions) (safe? k positions))
+ (flatmap
+ (lambda (rest-of-queens)
+ (map (lambda (new-row)
+ (adjoin-position new-row k rest-of-queens))
+ (enumerate-interval 1 board-size)))
+ (queen-cols (- k 1))))))
+ (queen-cols board-size))
+
+;; 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.
+(define empty-board '())
+
+;; take positions and append new-queen-row in the (new-queen-col - 1)st position in the list
+(define (adjoin-position new-queen-row new-queen-col positions)
+ (append positions
+ (list new-queen-row)))
+(define (safe? col positions)
+ (define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (let ((same-row?
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ all-but-last))
+ (same-positive-diagonal?
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + all-but-last (enumerate-interval 1 (- col 1)))))
+ (same-negative-diagonal?
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - all-but-last (enumerate-interval 1 (- col 1))))))
+ (not (or same-row? same-positive-diagonal? same-negative-diagonal?)))))
+
+
+;; (test-case (safe? 1 '(1)) #t)
+;; (test-case (safe? 4 '(2 4 1 1)) #f)
+;; (test-case (safe? 4 '(2 4 1 2)) #f)
+;; (test-case (safe? 4 '(2 4 1 3)) #t)
+;; (test-case (safe? 4 '(2 4 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 1)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 2)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 3)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 4)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 5)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 6)) #f)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 7)) #t)
+;; (test-case (safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+(queens 8)
blob - /dev/null
blob + 5794f879333a7ddbeebe241a0d495917c1c978ca (mode 644)
--- /dev/null
+++ ex2-43.lisp
+(defun louis-queens (board-size)
+ (louis-queen-cols board-size board-size))
+
+(defun louis-queen-cols (k board-size)
+ (if (= k 0)
+ (list empty-board)
+ (filter (lambda (positions) (safe k positions))
+ (flatmap
+ (lambda (new-row)
+ (mapcar
+ (lambda (rest-of-queens)
+ (adjoin-position new-row k rest-of-queens))
+ (louis-queen-cols (1- k) board-size)))
+ (enumerate-interval 1 board-size)))))
blob - /dev/null
blob + b66f5aaff72ceac9d5a2024adbbd30a9115137a6 (mode 644)
--- /dev/null
+++ ex2-43.scm
+;; (flatmap
+;; (lambda (new-row)
+;; (map (lambda (rest-of-queens)
+;; (adjoin-position new-row k rest-of-queens))
+;; (queen-cols (- k 1))))
+;; (enumerate-interval 1 board-size))
+
+;; This new mapping calls (queen-cols (- k 1)) board-size times upon each call to (queen-cols k).
+
+;; k calls to queen-cols
+;; 1 board-size
+;; 2 bs^2
+;; 3 bs^3
+;; ...
+;; bs bs^bs
+
+;; So, overall, it seems like ultimately, queen-cols is called board-size^board-size times. In the original version, queen-cols is only called board-size times. So, if it originally takes time T, the new version will take time T^T
blob - /dev/null
blob + 7a9e7474fa9cf998d91a5fc098bcba3c76f745a5 (mode 644)
--- /dev/null
+++ ex2-43.scm~
+(flatmap
+ (lambda (new-row)
+ (map (lambda (rest-of-queens)
+ (adjoin-position new-row k rest-of-queens))
+ (queen-cols (- k 1))))
+ (enumerate-interval 1 board-size))
blob - /dev/null
blob + d9aa5a327b3d20b11552fbaba4f0b126bcc31c94 (mode 644)
--- /dev/null
+++ ex2-44-sol.scm
+(define (up-split painter n)
+ (if (zero? n)
+ painter
+ (let ((smaller (up-split painter (- n 1))))
+ (below painter (beside smaller smaller)))))
blob - /dev/null
blob + 45b9cc91f79f84ede2426e2686be62e5f1fd88df (mode 644)
--- /dev/null
+++ ex2-44.scm
+(define wave2 (besides wave (flip-vert wave)))
+(define wave4 (below wave2 wave2))
+(define (flipped-pairs painter)
+ (let ((painter2 (besides painter (flip-vert painter))))
+ (below painter2 painter2)))
+(define wave4 (flipped-pairs wave))
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
blob - /dev/null
blob + 7a4a4519f088faf48fff7bfa82f1ca8f1fb6d813 (mode 644)
--- /dev/null
+++ ex2-44.scm~
+(define wave2 (besides wave (flip-vert wave)))
+(define wave4 (below wave2 wave2))
+(define (flipped-pairs painter)
+ (let ((painter2 (besides painter (flip-vert painter))))
+ (below painter2 painter2)))
+(define wave4 (flipped-pairs wave))
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
blob - /dev/null
blob + 31d4e53988825bec61dc4282913e1b904ecb8f68 (mode 644)
--- /dev/null
+++ ex2-45-sol.scm
+(define (split combine-main combine-smaller)
+ (lambda (painter n)
+ (if (zero? n)
+ painter
+ (let ((smaller ((split combine-main combine-smaller) painter (- n 1))))
+ (combine-main painter (combine-smaller smaller smaller))))))
blob - /dev/null
blob + a7307f291cb8cf2477db9ca674689202823ea506 (mode 644)
--- /dev/null
+++ ex2-45.scm
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
blob - /dev/null
blob + 2a6706f40e3eeb09966dbf3fedb41b7b3a5b27e6 (mode 644)
--- /dev/null
+++ ex2-45.scm~
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
blob - /dev/null
blob + 2eac32acd2d3541182e02916f953743f349f1ab9 (mode 644)
--- /dev/null
+++ ex2-46.scm
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
blob - /dev/null
blob + a7307f291cb8cf2477db9ca674689202823ea506 (mode 644)
--- /dev/null
+++ ex2-46.scm~
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
blob - /dev/null
blob + 1933a287c2e7427f0176b5d136f629d14940e4cf (mode 644)
--- /dev/null
+++ ex2-47-sol.scm
+(define (add-vect u v)
+ (make-vect
+ (+ (xcor-vect u) (xcor-vect v))
+ (+ (ycor-vect u) (ycor-vect v))))
+(define (sub-vect u v)
+ (make-vect
+ (- (xcor-vect u) (xcor-vect v))
+ (- (ycor-vect u) (ycor-vect v))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* s (ycor-vect v))))
+
+
blob - /dev/null
blob + ee4519baaddd0d9f9c83d2f8bfcf3d84874ab49e (mode 644)
--- /dev/null
+++ ex2-47-sol.scm~
+(define (make-frame dc origin edge1 edge2)
+ (list dc origin edge1 edge2))
+(define (dc-frame f)
+ (car f))
+(define (origin-frame f)
+ (cadr f))
+(define (edge1-frame f)
+ (caddr f))
+(define (edge2-frame f)
+ (cadddr f))
blob - /dev/null
blob + f02d7084f2b99dff052ce18541dff219df227b7c (mode 644)
--- /dev/null
+++ ex2-47.scm
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (make-frame origin edge1 edge2)
+ (cons origin (cons edge1 edge2)))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (cddr frame))
+
blob - /dev/null
blob + 2eac32acd2d3541182e02916f953743f349f1ab9 (mode 644)
--- /dev/null
+++ ex2-47.scm~
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
blob - /dev/null
blob + 09523fc4ef39347c9828a079d0752893cd0b0a07 (mode 644)
--- /dev/null
+++ ex2-48.scm
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
blob - /dev/null
blob + f02d7084f2b99dff052ce18541dff219df227b7c (mode 644)
--- /dev/null
+++ ex2-48.scm~
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (make-frame origin edge1 edge2)
+ (cons origin (cons edge1 edge2)))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (cddr frame))
+
blob - /dev/null
blob + 3cdfa4181430c88c36b89e27d74f4eb3f854ad42 (mode 644)
--- /dev/null
+++ ex2-49.scm
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
+
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
+ (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+
+;; last one is too much trouble
blob - /dev/null
blob + 09523fc4ef39347c9828a079d0752893cd0b0a07 (mode 644)
--- /dev/null
+++ ex2-49.scm~
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
blob - /dev/null
blob + e4bb84abebbfeb3a0095bbcc90d8a1cc732015ae (mode 644)
--- /dev/null
+++ ex2-5.lisp
+(defun divides? (a b)
+ (= (rem b a) 0))
+(defun my-cons (a b)
+ (* (expt 2 a) (expt 3 b)))
+(defun my-car (z)
+ (do ( (n 0 (1+ n))
+ (aa z (/ aa 2)))
+ ((not (divides? 2 aa)) n)))
+(defun my-cdr (z)
+ (do ( (n 0 (1+ n))
+ (aa z (/ aa 3)))
+ ((not (divides? 3 aa)) n)))
blob - /dev/null
blob + 232b68da7db0eb9a96e5adeb9afa3a4d06f7815a (mode 644)
--- /dev/null
+++ ex2-5.scm
+;; Exercise 2.5. Show that we can represent pairs of nonnegative integers using only numbers and arithmetic operations if we represent the pair a and b as the integer that is the product 2^a 3^b. Give the corresponding definitions of the procedures cons, car, and cdr.
+
+(define (expt base n)
+ (if (= n 0)
+ 1
+ (* base (expt base (- n 1)))))
+
+(define (cons a b)
+ (* (expt 2 a)
+ (expt 3 b)))
+
+(define (car x)
+ (if (not (= (remainder x 2) 0))
+ 0
+ (1+ (car (/ x 2)))))
+(define (cdr x)
+ (if (not (= (remainder x 3) 0))
+ 0
+ (1+ (cdr (/ x 3)))))
+
+(define (test-case actual expected)
+ (load-option 'format)
+ (newline)
+ (format #t "Actual: ~A Expected: ~A" actual expected))
+
+(test-case (car (cons 5 9)) 5)
+(test-case (cdr (cons 5 9)) 9)
+(test-case (car (cons 12 25)) 12)
+(test-case (cdr (cons 12 25)) 25)
+(test-case (car (cons 0 1)) 0)
+(test-case (cdr (cons 1 0)) 0)
+(test-case (car (cons 0 6)) 0)
+(test-case (cdr (cons 9 0)) 0)
+
blob - /dev/null
blob + dc855047f37e8aab86837aa40d33a184e283a296 (mode 644)
--- /dev/null
+++ ex2-5.scm~
+(defun my-cons (x y)
+ (lambda (m)
+ (cond ((= m 0) x)
+ ((= m 1) y)
+ (t (error "Argument not 0 or 1 -- CONS ~S~%" m)))))
+(defun my-car (z)
+ (funcall z 0))
+(defun my-cdr (z)
+ (funcall z 1))
+
+(defun
blob - /dev/null
blob + 692e9fa001335945a27e2b573c5ff91c6a8ee68a (mode 644)
--- /dev/null
+++ ex2-50.scm
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
+
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
+ (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+
+;; last one is too much trouble
+
+(define (transform-painter painter origin corner1 corner2)
+ (lambda (frame)
+ (let ((m (frame-coord-map frame)))
+ (let ((new-origin (m origin)))
+ (painter
+ (make-frame new-origin
+ (sub-vect (m corner1) new-origin)
+ (sub-vect (m corner2) new-origin)))))))
+(define (flip-vert painter)
+ (transform-painter painter
+ (make-vect 0.0 1.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (shrink-to-upper-right painter)
+ (transform-painter painter
+ (make-vect 0.5 0.5)
+ (make-vect 1.0 0.5)
+ (make-vect 0.5 1.0)))
+(define (rotate90 painter)
+ (transform-painter painter
+ (make-vect 1.0 0.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (squash-inwards painter)
+ (transform-painter painter
+ (make-vect 0.0 0.0)
+ (make-vect 0.65 0.35)
+ (make-vect 0.35 0.65)))
+(define (beside painter1 painter2)
+ (let ((split-point (make-vect 0.5 0.0)))
+ (let ((paint-left
+ (transform-painter painter1
+ (make-vect 0.0 0.0)
+ split-point
+ (make-vect 0.0 1.0)))
+ (paint-right
+ (transform-painter painter2
+ split-point
+ (make-vect 1.0 0.0)
+ (make-vect 0.5 1.0))))
+ (lambda (frame)
+ (paint-left frame)
+ (paint-right frame)))))
+
+;; Exercise 2.50. Define the transformation flip-horiz, which flips painters horizontally, and transformations that rotate painters counterclockwise by 180 degrees and 270 degrees.
+
+(define (flip-horiz painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 1.0)))
+
+(define (rotate180 painter)
+ (transform-painter painter
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 1.0)
+ (make-vector 1.0 0.0)))
+
+(define (rotate270 painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 0.0)))
+
+;; Exercise 2.51. Define the below operation for painters. Below takes two painters as arguments. The resulting painter, given a frame, draws with the first painter in the bottom of the frame and with the second painter in the top. Define below in two different ways -- first by writing a procedure that is analogous to the beside procedure given above, and again in terms of beside and suitable rotation operations (from exercise 2.50).
+
+(define (below
blob - /dev/null
blob + 3cdfa4181430c88c36b89e27d74f4eb3f854ad42 (mode 644)
--- /dev/null
+++ ex2-50.scm~
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
+
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
+ (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+
+;; last one is too much trouble
blob - /dev/null
blob + 99cc7b1c488a94fb6e360e77d80a2565dcceacf3 (mode 644)
--- /dev/null
+++ ex2-51-sol.scm
+(define (below painter1 painter2)
+ (let* ( (split-point (make-vect 0.0 0.5))
+ (paint-up
+ (transform-painter
+ painter2
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 0.0)
+ split-point))
+ (paint-down
+ (transform-painter
+ painter1
+ split-point
+ (make-vector 1.0 0.5)
+ (make-vector 0.0 1.0))))
+ (lambda (frame)
+ (paint-up frame)
+ (paint-down frame))))
+(define (below-rot painter1 painter2)
+ (rotate90 (beside
+ (rotate270 painter1)
+ (rotate270 painter2))))
+
+ Exercise 2.52. Make changes to the square limit of wave shown in figure 2.9 by working at each of the levels described above. In particular:
+
+a. Add some segments to the primitive wave painter of exercise 2.49 (to add a smile, for example).
+
+b. Change the pattern constructed by corner-split (for example, by using only one copy of the up-split and right-split images instead of two).
+
+c. Modify the version of square-limit that uses square-of-four so as to assemble the corners in a different pattern. (For example, you might make the big Mr. Rogers look outward from each corner of the square.)
blob - /dev/null
blob + 8fcac70745f248c035906e8851e256f928d9357c (mode 644)
--- /dev/null
+++ ex2-51-sol.scm~
+(define (below
blob - /dev/null
blob + 2505bfe40c66f911c2bd0320ffff43de19e2384a (mode 644)
--- /dev/null
+++ ex2-51.scm
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
+
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
+ (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+
+;; last one is too much trouble
+
+(define (transform-painter painter origin corner1 corner2)
+ (lambda (frame)
+ (let ((m (frame-coord-map frame)))
+ (let ((new-origin (m origin)))
+ (painter
+ (make-frame new-origin
+ (sub-vect (m corner1) new-origin)
+ (sub-vect (m corner2) new-origin)))))))
+(define (flip-vert painter)
+ (transform-painter painter
+ (make-vect 0.0 1.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (shrink-to-upper-right painter)
+ (transform-painter painter
+ (make-vect 0.5 0.5)
+ (make-vect 1.0 0.5)
+ (make-vect 0.5 1.0)))
+(define (rotate90 painter)
+ (transform-painter painter
+ (make-vect 1.0 0.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (squash-inwards painter)
+ (transform-painter painter
+ (make-vect 0.0 0.0)
+ (make-vect 0.65 0.35)
+ (make-vect 0.35 0.65)))
+(define (beside painter1 painter2)
+ (let ((split-point (make-vect 0.5 0.0)))
+ (let ((paint-left
+ (transform-painter painter1
+ (make-vect 0.0 0.0)
+ split-point
+ (make-vect 0.0 1.0)))
+ (paint-right
+ (transform-painter painter2
+ split-point
+ (make-vect 1.0 0.0)
+ (make-vect 0.5 1.0))))
+ (lambda (frame)
+ (paint-left frame)
+ (paint-right frame)))))
+
+;; Exercise 2.50. Define the transformation flip-horiz, which flips painters horizontally, and transformations that rotate painters counterclockwise by 180 degrees and 270 degrees.
+
+(define (flip-horiz painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 1.0)))
+
+(define (rotate180 painter)
+ (transform-painter painter
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 1.0)
+ (make-vector 1.0 0.0)))
+
+(define (rotate270 painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 0.0)))
+
+;; Exercise 2.51. Define the below operation for painters. Below takes two painters as arguments. The resulting painter, given a frame, draws with the first painter in the bottom of the frame and with the second painter in the top. Define below in two different ways -- first by writing a procedure that is analogous to the beside procedure given above, and again in terms of beside and suitable rotation operations (from exercise 2.50).
+
+(define (below bottom top)
+ (lambda (frame)
+ (let ((split-point (make-vector 0.0 0.5)))
+ (bot-transform (transform-painter bottom
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 0.0)
+ split-point))
+ (top-transform (transform-painter top
+ split-point
+ (make-vector 1.0 0.5)
+ (make-vector 0.0 1.0)))
+ (bottom frame)
+ (top frame))))
+(define (below bottom top)
+ (rotate90 (beside (rotate270 bottom) (rotate270 top))))
+
+(define (below painter1 painter2)
+ (let* ( (split-point (make-vect 0.0 0.5))
+ (paint-up
+ (transform-painter painter2
blob - /dev/null
blob + 692e9fa001335945a27e2b573c5ff91c6a8ee68a (mode 644)
--- /dev/null
+++ ex2-51.scm~
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
+
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
+ (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+
+;; last one is too much trouble
+
+(define (transform-painter painter origin corner1 corner2)
+ (lambda (frame)
+ (let ((m (frame-coord-map frame)))
+ (let ((new-origin (m origin)))
+ (painter
+ (make-frame new-origin
+ (sub-vect (m corner1) new-origin)
+ (sub-vect (m corner2) new-origin)))))))
+(define (flip-vert painter)
+ (transform-painter painter
+ (make-vect 0.0 1.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (shrink-to-upper-right painter)
+ (transform-painter painter
+ (make-vect 0.5 0.5)
+ (make-vect 1.0 0.5)
+ (make-vect 0.5 1.0)))
+(define (rotate90 painter)
+ (transform-painter painter
+ (make-vect 1.0 0.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (squash-inwards painter)
+ (transform-painter painter
+ (make-vect 0.0 0.0)
+ (make-vect 0.65 0.35)
+ (make-vect 0.35 0.65)))
+(define (beside painter1 painter2)
+ (let ((split-point (make-vect 0.5 0.0)))
+ (let ((paint-left
+ (transform-painter painter1
+ (make-vect 0.0 0.0)
+ split-point
+ (make-vect 0.0 1.0)))
+ (paint-right
+ (transform-painter painter2
+ split-point
+ (make-vect 1.0 0.0)
+ (make-vect 0.5 1.0))))
+ (lambda (frame)
+ (paint-left frame)
+ (paint-right frame)))))
+
+;; Exercise 2.50. Define the transformation flip-horiz, which flips painters horizontally, and transformations that rotate painters counterclockwise by 180 degrees and 270 degrees.
+
+(define (flip-horiz painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 1.0)))
+
+(define (rotate180 painter)
+ (transform-painter painter
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 1.0)
+ (make-vector 1.0 0.0)))
+
+(define (rotate270 painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 0.0)))
+
+;; Exercise 2.51. Define the below operation for painters. Below takes two painters as arguments. The resulting painter, given a frame, draws with the first painter in the bottom of the frame and with the second painter in the top. Define below in two different ways -- first by writing a procedure that is analogous to the beside procedure given above, and again in terms of beside and suitable rotation operations (from exercise 2.50).
+
+(define (below
blob - /dev/null
blob + e4987ef682a984daa274925591aa5c6651d0ab00 (mode 644)
--- /dev/null
+++ ex2-52.scm
+(define (right-split painter n)
+ (if (= n 0)
+ painter
+ (let ((smaller (right-split painter (- n 1))))
+ (beside painter (below smaller smaller)))))
+(define (corner-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1)))
+ (right (right-split painter (- n 1))))
+ (let ((top-left (beside up up))
+ (bottom-right (below right right))
+ (corner (corner-split painter (- n 1))))
+ (beside (below painter top-left)
+ (below bottom-right corner))))))
+(define (square-limit painter n)
+ (let ((quarter (corner-split painter n)))
+ (let ((half (beside (flip-horiz quarter) quarter)))
+ (below (flip-vert half) half))))
+(define (up-split painter n)
+ (if (= n 0)
+ painter
+ (let ((up (up-split painter (- n 1))))
+ (below painter (beside up up)))))
+(define (square-of-four tl tr bl br)
+ (lambda (painter)
+ (let ((top (beside (tl painter) (tr painter)))
+ (bottom (beside (bl painter) (br painter))))
+ (below bottom top))))
+
+(define (flipped-pairs painter)
+ (let ((combine4 (square-of-four identity flip-vert
+ identity flip-vert)))
+ (combine4 painter)))
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four flip-horiz identity
+ rotate180 flip-vert)))
+ (combine4 (corner-split painter n))))
+
+(define (split op1 op2)
+ (define (split-n painter n)
+ (if (= n 0)
+ painter
+ (let ((split-painter (split-n painter (- n 1))))
+ (op1 painter (op2 split-painter split-painter)))))
+ split-n)
+
+(define right-split (split beside below))
+(define up-split (split below beside))
+
+(define (frame-coord-map frame)
+ (lambda (v)
+ (add-vect
+ (origin-frame frame)
+ (add-vect (scale-vect (xcor-vect v)
+ (edge1-frame frame))
+ (scale-vect (ycor-vect v)
+ (edge2-frame frame))))))
+
+(define (make-vect xcor ycor)
+ (cons xcor ycor))
+(define (xcor-vect v)
+ (car v))
+(define (ycor-vect v)
+ (cdr v))
+(define (add-vect v1 v2)
+ (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+ (+ (ycor-vect v1) (ycor-vect v2))))
+(define (sub-vect v1 v2)
+ (make-vect (- (xcor-vect v1) (xcor-vect v2))
+ (- (ycor-vect v1) (ycor-vect v2))))
+(define (scale-vect s v)
+ (make-vect (* s (xcor-vect v))
+ (* x (ycor-vect v))))
+
+;; Exercise 2.47. Here are two possible constructors for frames:
+
+(define (make-frame origin edge1 edge2)
+ (list origin edge1 edge2))
+(define (origin-frame frame)
+ (car frame))
+(define (edge1-frame frame)
+ (cadr frame))
+(define (edge2-frame frame)
+ (caddr frame))
+
+(define (segments->painter segment-list)
+ (lambda (frame)
+ (for-each
+ (lambda (segment)
+ (draw-line
+ ((frame-coord-map frame) (start-segment segment))
+ ((frame-coord-map frame) (end-segment segment))))
+ segment-list)))
+
+(define (make-vect xcor ycor)
+(define (xcor-vect v)
+(define (ycor-vect v)
+(define (add-vect v1 v2)
+(define (sub-vect v1 v2)
+(define (scale-vect s v)
+
+
+(define (make-segment start end)
+ (list start end))
+(define (start-segment segment)
+ (car segment))
+(define (end-segment segment)
+ (cadr segment))
+
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
+ (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
+ (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+(segments->painter
+ (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
+ (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
+ (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
+ (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
+
+;; last one is too much trouble
+
+(define (transform-painter painter origin corner1 corner2)
+ (lambda (frame)
+ (let ((m (frame-coord-map frame)))
+ (let ((new-origin (m origin)))
+ (painter
+ (make-frame new-origin
+ (sub-vect (m corner1) new-origin)
+ (sub-vect (m corner2) new-origin)))))))
+(define (flip-vert painter)
+ (transform-painter painter
+ (make-vect 0.0 1.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (shrink-to-upper-right painter)
+ (transform-painter painter
+ (make-vect 0.5 0.5)
+ (make-vect 1.0 0.5)
+ (make-vect 0.5 1.0)))
+(define (rotate90 painter)
+ (transform-painter painter
+ (make-vect 1.0 0.0)
+ (make-vect 1.0 1.0)
+ (make-vect 0.0 0.0)))
+(define (squash-inwards painter)
+ (transform-painter painter
+ (make-vect 0.0 0.0)
+ (make-vect 0.65 0.35)
+ (make-vect 0.35 0.65)))
+(define (beside painter1 painter2)
+ (let ((split-point (make-vect 0.5 0.0)))
+ (let ((paint-left
+ (transform-painter painter1
+ (make-vect 0.0 0.0)
+ split-point
+ (make-vect 0.0 1.0)))
+ (paint-right
+ (transform-painter painter2
+ split-point
+ (make-vect 1.0 0.0)
+ (make-vect 0.5 1.0))))
+ (lambda (frame)
+ (paint-left frame)
+ (paint-right frame)))))
+
+;; Exercise 2.50. Define the transformation flip-horiz, which flips painters horizontally, and transformations that rotate painters counterclockwise by 180 degrees and 270 degrees.
+
+(define (flip-horiz painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 1.0)))
+
+(define (rotate180 painter)
+ (transform-painter painter
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 1.0)
+ (make-vector 1.0 0.0)))
+
+(define (rotate270 painter)
+ (transform-painter painter
+ (make-vector 1.0 0.0)
+ (make-vector 1.0 1.0)
+ (make-vector 0.0 0.0)))
+
+;; Exercise 2.51. Define the below operation for painters. Below takes two painters as arguments. The resulting painter, given a frame, draws with the first painter in the bottom of the frame and with the second painter in the top. Define below in two different ways -- first by writing a procedure that is analogous to the beside procedure given above, and again in terms of beside and suitable rotation operations (from exercise 2.50).
+
+(define (below bottom top)
+ (lambda (frame)
+ (let ((split-point (make-vector 0.0 0.5)))
+ (bot-transform (transform-painter bottom
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 0.0)
+ split-point))
+ (top-transform (transform-painter top
+ split-point
+ (make-vector 1.0 0.5)
+ (make-vector 0.0 1.0)))
+ (bottom frame)
+ (top frame))))
+(define (below bottom top)
+ (rotate90 (beside (rotate270 bottom) (rotate270 top))))
+
+(define (below painter1 painter2)
+ (let* ( (split-point (make-vect 0.0 0.5))
+ (paint-up
+ (transform-painter painter2
+
+;; Exercise 2.52. Make changes to the square limit of wave shown in figure 2.9 by working at each of the levels described above. In particular:
+
+;; c. Modify the version of square-limit that uses square-of-four so as to assemble the corners in a different pattern. (For example, you might make the big Mr. Rogers look outward from each corner of the square.)
+
+(define (square-limit painter n)
+ (let ((combine4 (square-of-four identity flip-horiz
+ flip-vert (compose flip-vert flip-horiz))))
+;;rotate180
+ (combine4 (corner-split painter n))))
+
blob - /dev/null
blob + 3d5ad8284468ab19965af719f6db930d4a5644c8 (mode 644)
--- /dev/null
+++ ex2-52.scm~
+(define (below painter1 painter2)
+ (let* ( (split-point (make-vect 0.0 0.5))
+ (paint-up
+ (transform-painter
+ painter2
+ (make-vector 0.0 0.0)
+ (make-vector 1.0 0.0)
+ split-point))
+ (paint-down
+ (transform-painter
+ painter1
+ split-point
+ (make-vector 1.0 0.5)
+ (make-vector 0.0 1.0))))
+ (lambda (frame)
+ (paint-up frame)
+ (paint-down frame))))
+(define (below-rot painter1 painter2)
+ (rotate90 (beside
+ (rotate270 painter1)
+ (rotate270 painter2))))
+
+ Exercise 2.52. Make changes to the square limit of wave shown in figure 2.9 by working at each of the levels described above. In particular:
+
blob - /dev/null
blob + 85f3859a5893cc3af1712322613c309d8ca04608 (mode 644)
--- /dev/null
+++ ex2-53.lisp
+(defun memq (item x)
+ (cond ((null x) nil)
+ ((eql item (car x)) x)
+ (t (memq item (cdr x)))))
+
+
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + b365a57954a233c8225d1db16bcc33a008d0ee16 (mode 644)
--- /dev/null
+++ ex2-53.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (memq item x)
+ (cond ((null? x) false)
+ ((eq? item (car x)) x)
+ (else (memq item (cdr x)))))
+(test-case (list 'a 'b 'c) '(a b c))
+(test-case (list (list 'george)) '((george)))
+(test-case (cdr '((x1 x2) (y1 y2))) '((y1 y2)))
+(test-case (cadr '((x1 x2) (y1 y2))) '(y1 y2))
+(test-case (pair? (car '(a short list))) #f)
+(test-case (memq 'red '((red shoes) (blue socks))) #f)
+(test-case (memq 'red '(red shoes blue socks)) '(red shoes blue socks))
blob - /dev/null
blob + 9160f9f4ab4df631708415f26d6a19582730ea1c (mode 644)
--- /dev/null
+++ ex2-53.scm~
+(* (+ 23 45) (+ x 9))
+(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))
blob - /dev/null
blob + 3f82db01cc48dce390acd81990a37b8b36e385b3 (mode 644)
--- /dev/null
+++ ex2-54-sol.scm
+(define (equal? p1 p2)
+ (cond ((and (null? p1) (null? p2)) #t)
+ ((or (null? p1) (null? p2)) #f)
+ ((and (pair? p1) (pair? p2))
+ (and (equal? (car p1) (car p2))
+ (equal? (cdr p1) (cdr p2))))
+ ((or (pair? p1) (pair? p2)) #f)
+ (else (eq? p1 p2))))
+(car ''abracadabra)
blob - /dev/null
blob + 865b39749e13f5865d99d98c878d1989b400525d (mode 644)
--- /dev/null
+++ ex2-54-sol.scm~
+(define (equal? p1 p2)
+ (cond ((and (null? p1) (null? p2)) #t)
+ ((or (null? p1) (null? p2)) #f)
+ ((and (pair? p1) (pair? p2))
+ (and (equal? (car p1) (car p2))
+ (equal? (cdr p1) (cdr p2))))
+ ((or (pair? p1) (pair? p2)) #f)
+ (else (eq? p1 p2))))
blob - /dev/null
blob + 837d67ccb61eba4eb66563b4b0b3d117c11e2fd5 (mode 644)
--- /dev/null
+++ ex2-54.lisp
+(defun memq (item x)
+ (cond ((null x) nil)
+ ((eql item (car x)) x)
+ (t (memq item (cdr x)))))
+
+(defun equal? (la lb)
+ (cond
+ ((and (symbolp la) (symbolp lb))
+ (eql la lb))
+ ((symbolp la) (symbolp lb))
+ ((symbolp lb) (symbolp la))
+ ((null la) (null lb))
+ ((null lb) (null la))
+ (t (and
+ (equal? (car la) (car lb))
+ (equal? (cdr la) (cdr lb))))))
blob - /dev/null
blob + 03da06aa24322e5cf49e397df7d4e8263f0d68c6 (mode 644)
--- /dev/null
+++ ex2-54.lisp~
+(defun memq (item x)
+ (cond ((null x) nil)
+ ((eql item (car x)) x)
+ (t (memq item (cdr x)))))
+
+(defun equal?
blob - /dev/null
blob + 1b36124a2ec8089f8933c754c9e9cdc9451d0967 (mode 644)
--- /dev/null
+++ ex2-54.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (memq item x)
+ (cond ((null? x) false)
+ ((eq? item (car x)) x)
+ (else (memq item (cdr x)))))
+
+(define (equal? a b)
+ (cond ((and (null? a)
+ (null? b))
+ #t)
+ ((and (not (pair? a))
+ (not (pair? b))
+ (eq? a b))
+ #t)
+ ((and (pair? a)
+ (pair? b))
+ (and (equal? (car a) (car b))
+ (equal? (cdr a) (cdr b))))
+ (else #f)))
+
+(test-case (equal? 4 4) #t)
+(test-case (equal? 4 0) #f)
+(test-case (equal? 4 '()) #f)
+(test-case (equal? '() 4) #f)
+(test-case (equal? '() '()) #t)
+(test-case (equal? '(4) '()) #f)
+(test-case (equal? '((4) (3)) '((4 3))) #f)
+(test-case (equal? '((4) (3)) '((4) (3))) #t)
+(test-case (equal? '((4) (3)) '((4) (2))) #f)
+(test-case (equal? '(4 3 2) '(4 3 2 5)) #f)
blob - /dev/null
blob + abdf15a6d391c4c1aa8909660d3176559a20581f (mode 644)
--- /dev/null
+++ ex2-54.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (memq item x)
+ (cond ((null? x) false)
+ ((eq? item (car x)) x)
+ (else (memq item (cdr x)))))
+(test-case (list 'a 'b 'c) '(a b c))
+(test-case (list (list 'george)) '((george)))
+(test-case (cdr '((x1 x2) (y1 y2))) '((y1 y2)))
+(test-case (cadr '((x1 x2) (y1 y2))) '(y1 y2))
+(test-case (pair? (car '(a short list))) #f)
+(test-case (memq 'red '((red shoes) (blue socks))) #f)
+(test-case (memq 'red '(red shoes blue socks)) '(red shoes blue socks))
+
+ Exercise 2.54. Two lists are said to be equal? if they contain equal elements arranged in the same order. For example,
+
+(equal? '(this is a list) '(this is a list))
+
+is true, but
+
+(equal? '(this is a list) '(this (is a) list))
+
+is false. To be more precise, we can define equal? recursively in terms of the basic eq? equality of symbols by saying that a and b are equal? if they are both symbols and the symbols are eq?, or if they are both lists such that (car a) is equal? to (car b) and (cdr a) is equal? to (cdr b). Using this idea, implement equal? as a procedure.36
blob - /dev/null
blob + af9e196b3b38f67b265198a6f8e1974bf5ca243b (mode 644)
--- /dev/null
+++ ex2-55.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (memq item x)
+ (cond ((null? x) false)
+ ((eq? item (car x)) x)
+ (else (memq item (cdr x)))))
+
+(define (equal? a b)
+ (cond ((and (null? a)
+ (null? b))
+ #t)
+ ((and (not (pair? a))
+ (not (pair? b))
+ (eq? a b))
+ #t)
+ ((and (pair? a)
+ (pair? b))
+ (and (equal? (car a) (car b))
+ (equal? (cdr a) (cdr b))))
+ (else #f)))
+
+(test-case (equal? 4 4) #t)
+(test-case (equal? 4 0) #f)
+(test-case (equal? 4 '()) #f)
+(test-case (equal? '() 4) #f)
+(test-case (equal? '() '()) #t)
+(test-case (equal? '(4) '()) #f)
+(test-case (equal? '((4) (3)) '((4 3))) #f)
+(test-case (equal? '((4) (3)) '((4) (3))) #t)
+(test-case (equal? '((4) (3)) '((4) (2))) #f)
+(test-case (equal? '(4 3 2) '(4 3 2 5)) #f)
+
+;; Exercise 2.55. Eva Lu Ator types to the interpreter the expression
+
+(car ''abracadabra)
+
+;; To her surprise, the interpreter prints back quote. Explain.
+
+(car '(quote abracadabra))
+(car (list quote abracadabra))
+;; ''abracadabra is actually (quote (quote abracadabra)), which is the same as '(quote abracadabra). The interpreter sees the symbol quote as the first element in a two-element list.
blob - /dev/null
blob + 1b36124a2ec8089f8933c754c9e9cdc9451d0967 (mode 644)
--- /dev/null
+++ ex2-55.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (memq item x)
+ (cond ((null? x) false)
+ ((eq? item (car x)) x)
+ (else (memq item (cdr x)))))
+
+(define (equal? a b)
+ (cond ((and (null? a)
+ (null? b))
+ #t)
+ ((and (not (pair? a))
+ (not (pair? b))
+ (eq? a b))
+ #t)
+ ((and (pair? a)
+ (pair? b))
+ (and (equal? (car a) (car b))
+ (equal? (cdr a) (cdr b))))
+ (else #f)))
+
+(test-case (equal? 4 4) #t)
+(test-case (equal? 4 0) #f)
+(test-case (equal? 4 '()) #f)
+(test-case (equal? '() 4) #f)
+(test-case (equal? '() '()) #t)
+(test-case (equal? '(4) '()) #f)
+(test-case (equal? '((4) (3)) '((4 3))) #f)
+(test-case (equal? '((4) (3)) '((4) (3))) #t)
+(test-case (equal? '((4) (3)) '((4) (2))) #f)
+(test-case (equal? '(4 3 2) '(4 3 2 5)) #f)
blob - /dev/null
blob + 9e659186182c0ed1d5c445bd4bbc66d439288dcb (mode 644)
--- /dev/null
+++ ex2-56-sol.scm
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp)
+ (if (same-variable? exp var) 1 0))
+ ((sum? exp)
+ (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp)
+ (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (else
+ (error "unknown expression type -- DERIV" exp))))
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+(define (exponentiation? x)
+ (and (pair? x) (eq? (car x) '**)))
+(define (base e) (cadr e))
+(define (exponent e) (caddr e))
blob - /dev/null
blob + acf16f3817925ece7dd95639b9192418882a3066 (mode 644)
--- /dev/null
+++ ex2-56-sol.scm~
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp)
+ (if (same-variable? exp var) 1 0))
+ ((sum? exp)
+ (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp)
+ (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (else
+ (error "unknown expression type -- DERIV" exp))))
blob - /dev/null
blob + 950240996369b7cb31664ad4b57d5b7b40875662 (mode 644)
--- /dev/null
+++ ex2-56.lisp
+(defun make-exponentiation (base exp)
+ (cond ((=number? exp 0) 1)
+ ((=number? exp 1) base)
+ ((and (numberp base) (numberp exp))
+ (expt base exp))
+ (t (list '** base exp))))
+
+(defun exponentiation? (x)
+ (and (consp x) (eql (car x) '**)))
+(defun base (x)
+ (cadr s))
+(defun exponent (s)
+ (caddr s))
+(defun deriv (expr var)
+ (cond ((numberp expr) 0)
+ ((variable? expr)
+ (if (same-variable? expr var) 1 0))
+ ((exponentiation? expr)
+ (make-product
+ (make-product
+ (exponent expr)
+ (make-exponentiation
+ (base expr)
+ (1- (exponent expr))))
+ (deriv (base expr) var)))
+ ((sum? expr)
+ (make-sum (deriv (addend expr) var)
+ (deriv (augend expr) var)))
+ ((product? expr)
+ (make-sum
+ (make-product (multiplier expr)
+ (deriv (multiplicand expr) var))
+ (make-product (deriv (multiplier expr) var)
+ (multiplicand expr))))
+ (t (error "unknown expression type -- DERIV ~A" expr))))
+
blob - /dev/null
blob + dc48c676007dde7e3577624029e29ca14a7e0e8c (mode 644)
--- /dev/null
+++ ex2-56.lisp~
+(defun make-exponentiation (base exp)
+ (cond ((=number? exp 0) 1)
+ ((=number? exp 1) base)
+ ((and (numberp base) (numberp exp))
+ (expt base exp))
+ (t (list '** base exp))))
blob - /dev/null
blob + f688ddbf1820fc59b0d4c79def479961da528160 (mode 644)
--- /dev/null
+++ ex2-56.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+;; Exercise 2.56. Show how to extend the basic differentiator to handle more kinds of expressions. For instance, implement the differentiation rule
+
+;; d(u^n)/dx = n*u^(n-1) * (du/dx)
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp) (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp) (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+;; warning, does not warn if x = 0 for 0^x
+
+;;(test-case (make-exponentiation 0 0) "0^0 undefined")
+(test-case (make-exponentiation 0 1) 0)
+(test-case (make-exponentiation 1 0) 1)
+(test-case (make-exponentiation 5 5) 3125)
+(test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 'x 1) 'x)
+(test-case (make-exponentiation 1 'x) 1)
+(test-case (make-exponentiation 'x 5) '(** x 5))
+(test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 5 'x) '(** 5 x))
+(test-case (make-exponentiation 'x 'x) '(** x x))
+
+(test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
+ (make-product 3 (make-exponentiation 'x 2)))
+ (make-product 2 'x))
+ 'x)
+ '(+ (+ (* 3 (** x 2))
+ (* 6 x))
+ 2))
+
blob - /dev/null
blob + f688ddbf1820fc59b0d4c79def479961da528160 (mode 644)
--- /dev/null
+++ ex2-56.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+;; Exercise 2.56. Show how to extend the basic differentiator to handle more kinds of expressions. For instance, implement the differentiation rule
+
+;; d(u^n)/dx = n*u^(n-1) * (du/dx)
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp) (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp) (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+;; warning, does not warn if x = 0 for 0^x
+
+;;(test-case (make-exponentiation 0 0) "0^0 undefined")
+(test-case (make-exponentiation 0 1) 0)
+(test-case (make-exponentiation 1 0) 1)
+(test-case (make-exponentiation 5 5) 3125)
+(test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 'x 1) 'x)
+(test-case (make-exponentiation 1 'x) 1)
+(test-case (make-exponentiation 'x 5) '(** x 5))
+(test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 5 'x) '(** 5 x))
+(test-case (make-exponentiation 'x 'x) '(** x x))
+
+(test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
+ (make-product 3 (make-exponentiation 'x 2)))
+ (make-product 2 'x))
+ 'x)
+ '(+ (+ (* 3 (** x 2))
+ (* 6 x))
+ 2))
+
blob - /dev/null
blob + 5a23284b0846c6597d0701308ee0638e39a1a940 (mode 644)
--- /dev/null
+++ ex2-57-sol.scm
+(define (non-num-members as)
+ (filter (lambda (x) (not (number? x)))
+ as))
+(define (num-members as)
+ (filter number? as))
+(define (more-than-one-number? as)
+ (let ((nums (num-members as)))
+ (if (or (null? nums) (null? (cdr nums)))
+ false
+ true)))
+(define (zero-is-the-only-number? as)
+ (let ((nums (num-members as)))
+ (if (null? nums)
+ false
+ (and (= (car nums) 0) (null? (cdr nums))))))
+
+(define (make-sum . as)
+ (cond ((null? as) 0)
+ ((null? (cdr as)) (car as))
+ ((null? (non-num-members as)) (apply + as))
+ ((more-than-one-number? as)
+ (apply make-sum
+ (append (non-num-members as)
+ (list (apply + (num-members as))))))
+ ((zero-is-the-only-number? as)
+ (apply make-sum (non-num-members as)))
+ (else (append '(+) as))))
+(define (make-product . ms)
+ (cond ((null? ms) 1)
+ ((null? (cdr ms)) (car ms))
+ ((null? (non-num-members ms)) (apply * ms))
+ ((more-than-one-number? ms)
+ (apply make-product
+ (append (non-num-members ms)
+ (list (apply * (num-members ms))))))
+ ((zero-is-the-only-number? ms) 0)
+ ((one-is-the-only-number? ms)
+ (apply make-product (non-num-members ms)))
+ (else (append '(*) ms))))
+
+
+(define (augend s)
+ (apply make-sum (cddr s)))
+(define (multiplicand p)
+ (apply make-product (cddr p)))
blob - /dev/null
blob + 56b01a75e73106c2c746481a416257f1206d3620 (mode 644)
--- /dev/null
+++ ex2-57-sol.scm~
+(define (augend s)
+ (if (null? (cdddr s))
+ (caddr s)
+ (cons '+ (cddr s))))
blob - /dev/null
blob + 0a0422b99b5fdf5eab4c7f735848d79c3f916c53 (mode 644)
--- /dev/null
+++ ex2-57.lisp
+(defun make-sum (&rest nums)
+ (append (list '+) nums))
+
+(make-sum '())
+'(+)
+(make-sum '(3))
+'(+ 3)
+(make-sum '(3 4))
+'(+ 3 4)
+(make-sum '(3 4 5))
+'(+ 3 4 5)
+(defun sum? (x)
+ (and (consp x) (eql (car x) '+)))
+(defun addend (s)
+ (cadr s))
+(defun augend (s)
+ (let ((aug (cddr s)))
+ (if (= (length aug) 1)
+ (car aug)
+ (append (list '+) aug))))
+(defun make-product (&rest nums)
+ (append (list '*) nums))
+(defun product? (x)
+ (and (consp x) (eql (car x) '*)))
+(defun multiplier (s)
+ (cadr s))
+(defun multiplicand (s)
+ (let ((m (cddr s)))
+ (if (= (length m) 1)
+ (car m)
+ (append (list '*) m))))
blob - /dev/null
blob + 161101bcd96899f1699b0d93d7bef6dc044f9534 (mode 644)
--- /dev/null
+++ ex2-57.lisp~
+(defun make-sum (&rest nums)
+ (append (list '+) nums))
blob - /dev/null
blob + 9570f7c39876dfdf9d8fc6b90ed2700addb15ade (mode 644)
--- /dev/null
+++ ex2-57.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+;; Exercise 2.56. Show how to extend the basic differentiator to handle more kinds of expressions. For instance, implement the differentiation rule
+
+;; d(u^n)/dx = n*u^(n-1) * (du/dx)
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp) (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp) (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+;; warning, does not warn if x = 0 for 0^x
+
+;;(test-case (make-exponentiation 0 0) "0^0 undefined")
+(test-case (make-exponentiation 0 1) 0)
+(test-case (make-exponentiation 1 0) 1)
+(test-case (make-exponentiation 5 5) 3125)
+(test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 'x 1) 'x)
+(test-case (make-exponentiation 1 'x) 1)
+(test-case (make-exponentiation 'x 5) '(** x 5))
+(test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 5 'x) '(** 5 x))
+(test-case (make-exponentiation 'x 'x) '(** x x))
+
+(test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
+ (make-product 3 (make-exponentiation 'x 2)))
+ (make-product 2 'x))
+ 'x)
+ '(+ (+ (* 3 (** x 2))
+ (* 6 x))
+ 2))
+
+;; Exercise 2.57. Extend the differentiation program to handle sums and products of arbitrary numbers of (two or more) terms. Then the last example above could be expressed as
+
+;; (deriv '(* x y (+ x 3)) 'x)
+
+;; Try to do this by changing only the representation for sums and products, without changing the deriv procedure at all. For example, the addend of a sum would be the first term, and the augend would be the sum of the rest of the terms.
+
+;; (define (collect-terms term structure)
+;; ...)
+;; (make-sum 1 2 3 4 5)
+;; (+ 1 (+ 2 (+ 3 (+ 4 5))))
+
+;; (+ (+ (+ (+ 4 5)
+;; 3)
+;; 2)
+;; 1)
+
+;; (+ 1 x 4 y -2)
+;; (+ 3 x y)
+;; (+
+
+;; (test-case (combine-terms 1 '()) 0)
+;; (test-case (combine-terms '(+ 1 2 3)
+;; (test-case (+ 1 x 4 y -2) '(+ 3 x y))
+;; (test-case (+ 1 (* x y) (* 2 x y) -3) '(+ -2 (* 3 x y)))
+
+;; (test-case (combine-constants '(+ 1 2 3)) 6)
+;; (define (combine-constants exp)
+;; (define (combine accum terms)
+;; (cond ((null? terms) accum)
+;; ((number? terms) (+ accum terms))
+;; ((product? terms) terms)
+;; ((exponentiation? terms) terms)
+;; ((sum? terms)
+;; (if (number? (addend terms))
+;; (combine (+ accum (addend terms)) (augend terms))
+;; (make-sum ()
+
+;; (augend terms)
+;; (combine (+ accum (addend terms)) (augend terms)))))
+;; (combine 0 exp))
+
+;; combines terms within items that share term in common
+(define (combine-terms term items)
+ (cond ((null? items) 0)
+ ((
+ ((number? term)
+ ...)
+ (else ...)))
+
+;; we no longer combine constants, nor do we combine like terms
+;; all sums must have at least 2 terms
+(define (make-sum . items)
+ (cond ((null? items) 0)
+ ((null? (cdr items)) (car items))
+ (else (append (list '+) items))))
+
+;; (define (make-sum . exps)
+;; (define (make-sum-recur items)
+;; (cond ((null? items) 0)
+;; (else (list '+ (car items) (make-sum (cdr items))))))
+;; (make-sum-recur items))
+
+ ;; (if (null? augends)
+ ;; addend
+ ;; (cons addend (make-sum (car augends) (cdr augends)))))
+ ;; (list '+ addend augends))
+(define (make-product . items)
+ (append (list '*) items))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+;; assuming that all sums must contain at least 1 term
+'(+ 1 2)
+'(1 2)
+'(2)
+(define (augend s)
+ (cond ((null? (cddr s)) 0)
+ ((null? (cdddr s))
+ (caddr s))
+(define (multiplicand p) ...)
blob - /dev/null
blob + f688ddbf1820fc59b0d4c79def479961da528160 (mode 644)
--- /dev/null
+++ ex2-57.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+;; Exercise 2.56. Show how to extend the basic differentiator to handle more kinds of expressions. For instance, implement the differentiation rule
+
+;; d(u^n)/dx = n*u^(n-1) * (du/dx)
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp) (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp) (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+;; warning, does not warn if x = 0 for 0^x
+
+;;(test-case (make-exponentiation 0 0) "0^0 undefined")
+(test-case (make-exponentiation 0 1) 0)
+(test-case (make-exponentiation 1 0) 1)
+(test-case (make-exponentiation 5 5) 3125)
+(test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 'x 1) 'x)
+(test-case (make-exponentiation 1 'x) 1)
+(test-case (make-exponentiation 'x 5) '(** x 5))
+(test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 5 'x) '(** 5 x))
+(test-case (make-exponentiation 'x 'x) '(** x x))
+
+(test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
+ (make-product 3 (make-exponentiation 'x 2)))
+ (make-product 2 'x))
+ 'x)
+ '(+ (+ (* 3 (** x 2))
+ (* 6 x))
+ 2))
+
blob - /dev/null
blob + fd36fc4420c5206e6678d8e3ab7921b3ca088977 (mode 644)
--- /dev/null
+++ ex2-57b.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp) (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp) (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+ (error "unknown expression type -- DERIV" exp)))
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+;; warning, does not warn if x = 0 for 0^x
+
+;; (test-case (make-exponentiation 0 0) "0^0 undefined")
+;; (test-case (make-exponentiation 0 1) 0)
+;; (test-case (make-exponentiation 1 0) 1)
+;; (test-case (make-exponentiation 5 5) 3125)
+;; (test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
+;; (test-case (make-exponentiation 'x 1) 'x)
+;; (test-case (make-exponentiation 1 'x) 1)
+;; (test-case (make-exponentiation 'x 5) '(** x 5))
+;; (test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
+;; (test-case (make-exponentiation 5 'x) '(** 5 x))
+;; (test-case (make-exponentiation 'x 'x) '(** x x))
+
+(test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
+ (make-product 3 (make-exponentiation 'x 2)))
+ (make-product 2 'x))
+ 'x)
+ '(+ (+ (* 3 (** x 2))
+ (* 6 x))
+ 2))
+
+;; Exercise 2.57. Extend the differentiation program to handle sums and products of arbitrary numbers of (two or more) terms. Then the last example above could be expressed as
+
+;; (deriv '(* x y (+ x 3)) 'x)
+
+;; Try to do this by changing only the representation for sums and products, without changing the deriv procedure at all. For example, the addend of a sum would be the first term, and the augend would be the sum of the rest of the terms.
+
+(define (make-sum . exps)
+ (let* ((nums (filter number? exps))
+ (non-nums (filter (lambda (exp) (not (number? exp))) exps))
+ (num (fold-right + 0 nums)))
+ (cond ((= num 0) (cond ((null? non-nums) 0)
+ ((null? (cdr non-nums)) (car non-nums))
+ (else (append (list '+) non-nums))))
+ ((null? non-nums) num)
+ (else (append (list '+)
+ non-nums
+ (list num))))))
+(define (make-sum . exps)
+ (let* ((nums (filter number? exps))
+ (non-nums (filter (lambda (exp) (not (number? exp))) exps))
+ (num (fold-right + 0 nums)))
+ (cond ((= num 0) (cond ((null? non-nums) 0)
+ ((null? (cdr non-nums)) (car non-nums))
+ (else (append (list '+) non-nums))))
+ ((null? non-nums) num)
+ (else (append (list '+)
+ non-nums
+ (list num))))))
+(define (make-product . exps)
+ (let* ((nums (filter number? exps))
+ (non-nums (filter (lambda (exp) (not (number? exp))) exps))
+ (num (fold-right * 1 nums)))
+ (cond ((null? exps) 1)
+ ((= num 0) 0)
+ ((null? non-nums) num)
+ ((null? (cdr non-nums)) (if (= num 1)
+ (car non-nums)
+ (append (list '* num) non-nums)))
+ (else (if (= num 1)
+ (cons '* non-nums)
+ (append (list '* num) non-nums))))))
+
+ ;; ((= nums 1) (cond ((null? non-nums) 1)
+ ;; ((null? (cdr non-nums)) (car non-nums))
+ ;; (else (append (list '*) non-nums))))
+ ;; (else
+
+(test-case (make-sum) 0)
+(test-case (make-sum 0) 0)
+(test-case (make-sum 0 'x) 'x)
+(test-case (make-sum 1 2 3 4 5) 15)
+(test-case (make-sum 1 'x) '(+ x 1))
+(test-case (make-sum 1 5 'x) '(+ x 6))
+(test-case (make-sum 1 5 'x 'y) '(+ x y 6))
+(test-case (make-sum -3 3 'x 'y) '(+ x y))
+(test-case (make-sum -3 3 'x) 'x)
+(test-case (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 5) '(+ a b c d -2))
+(test-case (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 4 3) '(+ a b c d))
+(test-case (make-sum (make-product 5 'x)
+ (make-product 3 'y)
+ 2 5 -4)
+ '(+ (* 5 x) (* 3 y) 3))
+(test-case (make-sum (make-product 5 'x)
+ (make-product 2 0 'y)
+ (make-product (make-sum 5 -5) 'x)
+ (make-product (make-sum 2 4 -6) 'y)
+ (make-product (make-product 0 1) 'z)
+ (make-product 4 'z)
+ -3 -2 -1
+ (make-product 2 3))
+ '(+ (* 5 x) (* 4 z)))
+
+(test-case (make-product) 1)
+(test-case (make-product 1) 1)
+(test-case (make-product 5) 5)
+(test-case (make-product 'x) 'x)
+(test-case (make-product 5 'x) '(* 5 x))
+(test-case (make-product 5 2) 10)
+(test-case (make-product 0) 0)
+(test-case (make-product 0 1 3 2) 0)
+(test-case (make-product 0 'x) 0)
+(test-case (make-product 5 2 'x) '(* 10 x))
+(test-case (make-product 5 'x 'y 'z 0) 0)
+(test-case (make-product 5 'x 'y 'z) '(* 5 x y z))
+(test-case (make-product 5 'x 2 -3 'y) '(* -30 x y))
+(test-case (make-product 5 1/5 'x) 'x)
+(test-case (make-product 5 1/5 'x 'y) '(* x y))
+(test-case (make-product (make-sum 5 6 4 -2)
+ 'x 'y
+ (make-sum 1 -3 3))
+ '(* 13 x y))
+(test-case (make-product (make-sum (make-sum 2 4)
+ (make-product 3 -2))
+ (make-product 4 'y))
+ 0)
+
+
+(define (addend s) (cadr s))
+(define (augend s) (apply make-sum (cddr s)))
+;; alternatively,
+;; (if (null? (cdddr s))
+;; (caddr s)
+;; (apply make-sum (cddr s))))
+
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (apply make-product (cddr p)))
+
+(test-case (augend (make-sum 1 'x)) 1)
+(test-case (augend (make-sum 1 5 'x)) 6)
+(test-case (augend (make-sum 1 5 'x 'y)) '(+ y 6))
+(test-case (augend (make-sum -3 3 'x 'y)) 'y)
+(test-case (augend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 5)) '(+ b c d -2))
+(test-case (augend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 4 3)) '(+ b c d))
+(test-case (augend (make-sum (make-product 5 'x)
+ (make-product 3 'y)
+ 2 5 -4))
+ '(+ (* 3 y) 3))
+(test-case (augend (make-sum (make-product 5 'x)
+ (make-product 2 0 'y)
+ (make-product (make-sum 5 -5) 'x)
+ (make-product (make-sum 2 4 -6) 'y)
+ (make-product (make-product 0 1) 'z)
+ (make-product 4 'z)
+ -3 -2 -1
+ (make-product 2 3)))
+ '(* 4 z))
+
+(test-case (multiplicand (make-product 5 'x)) 'x)
+(test-case (multiplicand (make-product 5 'x 'y 'z)) '(* x y z))
+(test-case (multiplicand (make-product 5 'x 2 -3 'y)) '(* x y))
+(test-case (multiplicand (make-product (make-sum 5 6 4 -2)
+ 'x 'y
+ (make-sum 1 -3 3)))
+ '(* x y))
+(test-case (deriv '(* x y (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3))))
+;; (make-sum (make-product 'x (deriv '(* y (+ x 3)) 'x))
+;; '(* y (+ x 3))))
+;; (make-sum (make-product 'x 'y)
+;; '(* y (+ x 3)))
+;; (make-sum '(* x y)
+;; '(* y (+ x 3)))
+;; '(+ (* x y) (* y (+ x 3)))
+
blob - /dev/null
blob + 9570f7c39876dfdf9d8fc6b90ed2700addb15ade (mode 644)
--- /dev/null
+++ ex2-57b.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+(define (make-sum a1 a2) (list '+ a1 a2))
+(define (make-product m1 m2) (list '* m1 m2))
+(define (sum? x)
+ (and (pair? x) (eq? (car x) '+)))
+(define (addend s) (cadr s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (car x) '*)))
+(define (multiplier p) (cadr p))
+(define (multiplicand p) (caddr p))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+;; Exercise 2.56. Show how to extend the basic differentiator to handle more kinds of expressions. For instance, implement the differentiation rule
+
+;; d(u^n)/dx = n*u^(n-1) * (du/dx)
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp) (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp) (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; by adding a new clause to the deriv program and defining appropriate procedures exponentiation?, base, exponent, and make-exponentiation. (You may use the symbol ** to denote exponentiation.) Build in the rules that anything raised to the power 0 is 1 and anything raised to the power 1 is the thing itself.
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+;; warning, does not warn if x = 0 for 0^x
+
+;;(test-case (make-exponentiation 0 0) "0^0 undefined")
+(test-case (make-exponentiation 0 1) 0)
+(test-case (make-exponentiation 1 0) 1)
+(test-case (make-exponentiation 5 5) 3125)
+(test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 'x 1) 'x)
+(test-case (make-exponentiation 1 'x) 1)
+(test-case (make-exponentiation 'x 5) '(** x 5))
+(test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
+(test-case (make-exponentiation 5 'x) '(** 5 x))
+(test-case (make-exponentiation 'x 'x) '(** x x))
+
+(test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
+ (make-product 3 (make-exponentiation 'x 2)))
+ (make-product 2 'x))
+ 'x)
+ '(+ (+ (* 3 (** x 2))
+ (* 6 x))
+ 2))
+
+;; Exercise 2.57. Extend the differentiation program to handle sums and products of arbitrary numbers of (two or more) terms. Then the last example above could be expressed as
+
+;; (deriv '(* x y (+ x 3)) 'x)
+
+;; Try to do this by changing only the representation for sums and products, without changing the deriv procedure at all. For example, the addend of a sum would be the first term, and the augend would be the sum of the rest of the terms.
+
+;; (define (collect-terms term structure)
+;; ...)
+;; (make-sum 1 2 3 4 5)
+;; (+ 1 (+ 2 (+ 3 (+ 4 5))))
+
+;; (+ (+ (+ (+ 4 5)
+;; 3)
+;; 2)
+;; 1)
+
+;; (+ 1 x 4 y -2)
+;; (+ 3 x y)
+;; (+
+
+;; (test-case (combine-terms 1 '()) 0)
+;; (test-case (combine-terms '(+ 1 2 3)
+;; (test-case (+ 1 x 4 y -2) '(+ 3 x y))
+;; (test-case (+ 1 (* x y) (* 2 x y) -3) '(+ -2 (* 3 x y)))
+
+;; (test-case (combine-constants '(+ 1 2 3)) 6)
+;; (define (combine-constants exp)
+;; (define (combine accum terms)
+;; (cond ((null? terms) accum)
+;; ((number? terms) (+ accum terms))
+;; ((product? terms) terms)
+;; ((exponentiation? terms) terms)
+;; ((sum? terms)
+;; (if (number? (addend terms))
+;; (combine (+ accum (addend terms)) (augend terms))
+;; (make-sum ()
+
+;; (augend terms)
+;; (combine (+ accum (addend terms)) (augend terms)))))
+;; (combine 0 exp))
+
+;; combines terms within items that share term in common
+(define (combine-terms term items)
+ (cond ((null? items) 0)
+ ((
+ ((number? term)
+ ...)
+ (else ...)))
+
+;; we no longer combine constants, nor do we combine like terms
+;; all sums must have at least 2 terms
+(define (make-sum . items)
+ (cond ((null? items) 0)
+ ((null? (cdr items)) (car items))
+ (else (append (list '+) items))))
+
+;; (define (make-sum . exps)
+;; (define (make-sum-recur items)
+;; (cond ((null? items) 0)
+;; (else (list '+ (car items) (make-sum (cdr items))))))
+;; (make-sum-recur items))
+
+ ;; (if (null? augends)
+ ;; addend
+ ;; (cons addend (make-sum (car augends) (cdr augends)))))
+ ;; (list '+ addend augends))
+(define (make-product . items)
+ (append (list '*) items))
+
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list '+ a1 a2))))
+(define (=number? exp num)
+ (and (number? exp) (= exp num)))
+
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list '* m1 m2))))
+
+;; assuming that all sums must contain at least 1 term
+'(+ 1 2)
+'(1 2)
+'(2)
+(define (augend s)
+ (cond ((null? (cddr s)) 0)
+ ((null? (cdddr s))
+ (caddr s))
+(define (multiplicand p) ...)
blob - /dev/null
blob + b1cec46bd8957322c96705aeacfcdc6f86f4fcb5 (mode 644)
--- /dev/null
+++ ex2-58-sol.scm
+(define (non-num-members as)
+ (filter (lambda (x) (not (number? x))) as))
+(define (num-members as)
+ (filter number? as))
+(define (more-than-one-number? as)
+ (let ((nums (num-members as)))
+ (if (or (null? nums) (null? (cdr nums)))
+ #f
+ #t)))
+(define (zero-is-the-only-number? as)
+ (let ((nums (num-members as)))
+ (if (null? nums)
+ #f
+ (and (= (car nums) 0) (null? (cdr nums))))))
+(define (one-is-the-only-number? as)
+ (let ((nums (num-members as)))
+ (if (null? nums)
+ #f
+ (and (= (car nums) 1) (null? (cdr nums))))))
+(define (insert-signs result items sign)
+ (cond ((null? items) result)
+ ((null? result)
+ (insert-signs (list (car items)) (cdr items) sign))
+ (else (insert-signs (append result (list sign (car items)))
+ (cdr items) sign))))
+
+
blob - /dev/null
blob + f1c862d5f0b079baffb695cd462cad0a746e929c (mode 644)
--- /dev/null
+++ ex2-58-sol.scm~
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1) (number? a2)) (+ a1 a2))
+ (else (list a1 '+ a2))))
+(define (make-product m1 m2)
+ (cond ((or (=number? m1 0) (=number? m2 0)) 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1) (number? m2)) (* m1 m2))
+ (else (list m1 '* m2))))
+(define (sum? x)
+ (and (pair? x) (eq? (cadr x) '+)))
+(define (addend s) (car s))
+(define (augend s) (caddr s))
+(define (product? x)
+ (and (pair? x) (eq? (cadr x) '*)))
+(define (multiplier p) (car p))
+(define (multiplicand p) (caddr p))
+(define (non-num-members as)
+ (filter (lambda (x) (not (number? x))) as))
+(define (num-members as)
+ (filter number? as))
+(define (more-than-one-number? as)
+ (let ((nums (num-members as)))
+ (if (or (null? nums) (null? (cdr nums)))
+ #f
+ #t)))
+(define (zero-is-the-only-number? as)
+ (let ((nums (num-members as)))
+ (if (null? nums)
+ #f
+ (and (= (car nums) 0) (null? (cdr nums))))))
+(define (one-is-the-only-number? as)
+ (let ((nums (num-members as)))
+ (if (null? nums)
+ #f
+ (and (= (car nums) 1) (null? (cdr nums))))))
+(define (insert-signs result items sign)
+ (cond ((null? items) result)
+ ((null? result)
+ (insert-signs (list (car items)) (cdr items) sign))
+ (else (insert-signs (append result (list sign (car items)))
+ (cdr items) sign))))
+
+(define (make-sum . as)
+ (cond ((null? as) 0)
+ ((null? (cdr as)) (car as))
+ ((null? (non-num-members as)) (apply + as))
+ ((more-than-one-number? as)
+ (apply make-sum
+ (append (non-num-members as)
+ (list (apply + (num-members as))))))
+ ((zero-is-the-only-number? as)
+ (apply make-sum (non-num-members as)))
+ (else (insert-signs '() as '+))))
+(define (make-product . ms)
+ (cond ((null? ms) 1)
+ ((null? (cdr ms)) (car ms))
+ ((null? (non-num-members ms)) (apply * ms))
+ ((more-than-one-number? ms)
+ (apply make-product (append (non-num-members ms)
+ (list (apply * (num-members ms))))))
+ ((zero-is-the-only-number? ms) 0)
+ ((one-is-the-only-number? ms)
+ (apply make-product (non-num-members ms)))
+ (else (insert-signs '() ms '*))))
+(define (sum? x)
+ (cond ((not (pair? x)) #f)
+ ((member '+ x) true)
+ (else #f)))
+(define (product? x)
+ (cond ((not (pair? x)) #f)
+ ((and (not (sum? x)) (member '* x)) true)
+ (else #f)))
+(define (addend s)
+ (let* ((index (list-index (lambda (x) (eq? x '+)) s))
+ (a (take s index)))
+ (if (null? (cdr a))
+ (car a)
+ a)))
+(define (augend s)
+ (let* ((index (list-index (lambda (x) (eq? x '+)) s))
+ (b (drop s (+ index 1))))
+ (if (null? (cdr b))
+ (car b)
+ b)))
+(define (multiplier p)
+ (let* ((index (list-index (lambda (x) (eq? x '*)) p))
+ (a (take p index)))
+ (if (null? (cdr a))
+ (car a)
+ a)))
+(define (multiplicand p)
+ (let* ((index (list-index (lambda (x) (eq? x '*)) p))
+ (b (drop p (+ index 1))))
+ (if (null? (cdr b))
+ (car b)
+ b)))
+(multiplier '(x * y * (z + 2)))
blob - /dev/null
blob + 8ec5b5cf030cc84bf5dbd465a00fffa97008f516 (mode 644)
--- /dev/null
+++ ex2-58.lisp
+(defun make-sum (a1 a2)
+ (list a1 '+ a2))
+(defun make-product (m1 m2)
+ (list m1 '* m2))
+(defun sum? (x)
+ (and (consp x) (eql (cadr x) '+)))
+(defun addend (x)
+ (car x))
+(defun augend (s)
+ (caddr s))
+(defun product? (x)
+ (and (consp x) (eql (cadr x) '*)))
+(defun multiplier (s)
+ (car s))
+(defun multiplicand (s)
+ (caddr s))
+
+(defvar *stream* '() "Token stream")
+(defun init-stream (stream)
+ "Initialize the stream"
+ (setq *stream* stream))
+(defun next-token ()
+ "Returns the next token of the stream"
+ (car *stream*))
+(defun scan ()
+ (pop *stream*))
+(defvar *stream-stack* '() "Stack of streams")
+(defun push-stream (stream)
+ "Push the current *stream* on stack, and set this tream as *stream*"
+ (push *stream* *stream-stack*)
+ (init-stream stream))
+(defun pop-stream ()
+ (init-stream (pop *stream-stack)))
+(defun parse-factor ()
+ (let ((tok (next-token)))
+ (cond
+ ((or (numberp tok) (sybolp tok))
+ (scan)
+ tok)
+ ((listp tok)
+ (push-strea tok)
+ (let ((sum (parse-sum)))
+ (pop-stream)
+ (scan)
+ sum))
+ (t (error "Bad token in parse-atom -- ~A" tok)))))
+(defun parse-term ()
+ (let ((lfact (parse-factor)))
+ (if (eq (next-token) '*)
+ (progn
+ (scan)
+ (let ((rterm (parse-term)))
+ (list '* lfact rterm)))
+ lfact)))
+(defun (parse-
blob - /dev/null
blob + 8187faeb6e9aa6cceb2a8f0ebd984ce19aff79fc (mode 644)
--- /dev/null
+++ ex2-58.lisp~
+(defun make-sum (a1 a2)
+ (list a1 '+ a2))
+(defun make-product (m1 m2)
+ (list m1 '* m2))
+(defun sum? (x)
+ (and (consp x) (eql (cadr x) '+)))
+(defun addend (x)
+ (car x))
+(defun augend (s)
+ (caddr s))
+(defun product? (x)
+ (and (consp x) (eql (cadr x) '*)))
+(defun multiplier (s)
+ (car s))
+(defun multiplicand (s)
+ (caddr s))
blob - /dev/null
blob + 551fcf0f677d1750eb29c0f559807c0f721e210e (mode 644)
--- /dev/null
+++ ex2-58.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp) (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp) (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works?
+
+(define (add-signs exps sign)
+ (cond ((null? exps) '())
+ ((null? (cdr exps)) exps)
+ (else (cons (car exps)
+ (cons sign
+ (add-signs (cdr exps) sign))))))
+(define (add-plus-signs exps)
+ (cond ((null? exps) '())
+ ((null? (cdr exps)) exps)
+ ((sum? (car exps)) (append (list (addend (car exps))
+ (augend (car exps)))
+ (add-plus-signs (cdr exps))))
+ (else (append (list (car exps) '+)
+ (add-plus-signs (cdr exps))))))
+(define (add-mult-signs exps)
+ (cond ((null? exps) '())
+ ((null? (cdr exps)) exps)
+ (else (cons (car exps)
+ (cons '*
+ (add-mult-signs (cdr exps)))))))
+
+(define (make-sum . exps)
+ (let* ((nums (filter number? exps))
+ (non-nums (filter (lambda (exp) (not (number? exp))) exps))
+ (sum-of-nums (fold-right + 0 nums)))
+ (cond ((null? non-nums) sum-of-nums)
+ ((and (= sum-of-nums 0)
+ (null? (cdr non-nums))) (car non-nums))
+ ((= sum-of-nums 0) (add-plus-signs non-nums))
+ (else (add-plus-signs (append non-nums (list sum-of-nums)))))))
+(define (make-product . exps)
+ (let* ((nums (filter number? exps))
+ (non-nums (filter (lambda (exp) (not (number? exp))) exps))
+ (product-of-nums (fold-right * 1 nums)))
+ (cond ((null? non-nums) product-of-nums)
+ ((= product-of-nums 0) 0)
+ ((and (= product-of-nums 1)
+ (null? (cdr non-nums))) (car non-nums))
+ ((= product-of-nums 1) (add-mult-signs non-nums))
+ (else (add-mult-signs (cons product-of-nums non-nums))))))
+(define (addend s)
+ (if (eq? '+ (cadr s))
+ (list (car x))
+ (cons (car x)
+ (cons (cadr x)
+ (addend (cddr x))))))
+
+(define (augend s)
+ (cond ((and (eq? '+ (cadr s))
+ (null? (cdddr s)))
+ (caddr s))
+ ((eq? '+ (cadr s)) (cddr s))
+ ((eq? '* (cadr s)) (augend (cddr s)))))
+
+(define (sum? x)
+ (and (pair? x)
+ (not (null? (cdr x)))
+ (or (eq? (cadr x) '+)
+ (sum? (cddr x)))))
+
+(define (multiplier p) (car p))
+(define (multiplicand p) (caddr p))
+
+(define (product? x)
+ (and (pair? x) (eq? (cadr x) '*)))
+
+
+;; addend
+(test-case (addend '(a + b + c)) 'a)
+(test-case (addend '(3 * x + 4 * y)) '(3 * x))
+(test-case (addend '(4 + x * y * (1 + z) + (2 * 2))) '(y * x * (z + 1)))
+(test-case (addend '(2 * x * y + 4)) '(2 * x * y))
+
+;; augend
+(test-case (augend '(x + 6)) 6)
+(test-case (augend '(x + y + 6)) '(y + 6))
+(test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5))
+(test-case (augend '(5 * x + 3 * y + 3))
+ '(3 * y + 3))
+
+;; sum?
+(test-case (sum? '(5 + x)) #t)
+(test-case (sum? '(5 * x + 3)) #t)
+(test-case (sum? '(8 * x)) #f)
+(test-case (sum? 5) #f)
+(test-case (sum? '(5 * x + 8 * y)) #t)
+(test-case (sum? '(((5 * x) + 3) + 2)) #t)
+(test-case (make-sum 0 'x) 'x)
+(test-case (make-sum 1 2) 3)
+(test-case (make-sum 1 'x) '(x + 1))
+(test-case (make-sum 'x 'y) '(x + y))
+(test-case (make-sum (make-sum -3 'y)
+ (make-sum 3 'x)) '(y + -3 + x + 3)) ;; not the most simplified
+(test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d))
+(test-case (make-sum -3 'y 3 'x) '(y + x))
+(test-case (make-sum (make-product 2 'x 'y) 4) '(2 * x * y + 4))
+(test-case (make-sum 4 (make-product 2 'x 'y)) '(4 + 2 * x * y))
+(test-case (make-sum (make-product 3 'z) (make-product 2 'x 'y)) '(3 * z + 2 * x * y))
+(test-case (make-sum (make-product 'a 'b)
+ (make-product 'c (make-sum 'd 1) 'e)
+ (make-product (make-sum 'f 2) (make-sum 'g 3) 'h))
+ '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
+(test-case (make-product 5 'x) '(5 * x))
+(test-case (make-product 5 2) 10)
+(test-case (make-product 0 'x) 0)
+(test-case (make-product 5 2 'x) '(10 * x))
+(test-case (make-product 5 1/5 'x 'y) '(x * y))
+(test-case (make-product 5 (make-product 'x 'y) 'z) '(5 * x * y * z))
+(test-case (make-product (make-sum 5 'x)
+ (make-product 'x 'y)
+ (make-sum 'z 2))
+ '((5 + x) * x * y * (z + 2)))
+;; if we are dealing with sums, then we must add parentheses; otherwise, omit parentheses
+(test-case (make-sum (make-sum -5 6 'x)
+ 'y
+ (make-sum -3 3))
+ '(x + 1 + y)) ;; notice that the constant 1 is not right-most
+(test-case (make-product (make-sum 2 4 (make-product 3 -2))
+ (make-product 4 'y)) 0)
+(test-case (make-sum (make-product 5 'x)
+ (make-product 3 'y)
+ (make-product 2 'y)
+ (make-product 2 3))
+ '(5 * x + 3 * y + 2 * y + 6))
+(test-case (make-sum (make-product 5 'x 'y)
+ (make-product 4 'a 'b 'c))
+ '(5 * x * y + 4 * a * b * c))
+
+
+(test-case (multiplier '(20 * x * ( (make-product (make-product 5 4 'x (make-sum 1 'y))
+ (make-sum 2 'z)))
+ '(20 * x * (y + 1)))
+(test-case (multiplier (make-product (make-sum 5 6 4 -2)
+ 'x 'y
+ (make-sum 1 -3 3)))
+ 13)
+(test-case (multiplicand (make-product 5 'x)) 'x)
+(test-case (multiplicand (make-product 5 'x 'y 'z)) '(x * y * z))
+(test-case (multiplicand (make-product 5 'x 2 -3 'y)) '(x * y))
+(test-case (multiplicand (make-product (make-sum 5 6 4 -2)
+ 'x 'y
+ (make-sum 1 -3 3)))
+ '(x * y))
+
+(test-case (deriv '(* x y (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3))))
blob - /dev/null
blob + e72a051467120ae90b574e74ddf87a8d2ea4c2fe (mode 644)
--- /dev/null
+++ ex2-58.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp) (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp) (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works?
+
+(define (add-signs exps sign)
+ (cond ((null? exps) '())
+ ((null? (cdr exps)) exps)
+ (else (cons (car exps)
+ (cons sign
+ (add-signs (cdr exps) sign))))))
+(define (make-sum . exps)
+ (let* ((nums (filter number? exps))
+ (non-nums (filter (lambda (exp) (not (number? exp))) exps))
+ (sum-of-nums (fold-right + 0 nums)))
+ (cond ((null? non-nums) sum-of-nums)
+ ((and (= sum-of-nums 0)
+ (null? (cdr non-nums))) (car non-nums))
+ ((= sum-of-nums 0) (add-signs non-nums '+))
+ (else (add-signs (append non-nums (list sum-of-nums)) '+)))))
+(define (make-product . exps)
+ (let* ((nums (filter number? exps))
+ (non-nums (filter (lambda (exp) (not (number? exp))) exps))
+ (product-of-nums (fold-right * 1 nums)))
+ (cond ((null? non-nums) product-of-nums)
+ ((= product-of-nums 0) 0)
+ ((and (= product-of-nums 1)
+ (null? (cdr non-nums))) (car non-nums))
+ ((= product-of-nums 1) (add-signs non-nums '*))
+ (else (add-signs (cons product-of-nums non-nums) '*)))))
+(define (addend s)
+ (if (eq? '+ (cadr s))
+ (car s)
+ (cons (car s)
+ (addend (cddr s)))))
+(define (augend s)
+ (cond ((and (eq? '+ (cadr s))
+ (null? (cdddr s)))
+ (caddr s))
+ ((eq? '+ (cadr s)) (cddr s))
+ ((eq? '* (cadr s)) (augend (cddr s)))))
+(define (multiplier p) (car p))
+(define (multiplicand p) (caddr p))
+
+(define (sum? x)
+ (and (pair? x) (eq? (cadr x) '+)))
+(define (product? x)
+ (and (pair? x) (eq? (cadr x) '*)))
+
+
+(test-case (make-sum 0 'x) 'x)
+(test-case (make-sum 1 2) 3)
+(test-case (make-sum 1 'x) '(x + 1))
+(test-case (make-sum 'x 'y) '(x + y))
+(test-case (make-sum (make-sum -3 'y)
+ (make-sum 3 'x)) '(y + -3 + x + 3)) ;; not the most simplified
+(test-case (make-sum -3 'y 3 'x) '(y + x))
+(test-case (make-sum (make-product 2 'x 'y) 4) '(2 * x * y + 4))
+(test-case (make-sum 4 (make-product 2 'x 'y)) '(4 + 2 * x * y))
+(test-case (make-sum (make-product 3 'z) (make-product 2 'x 'y)) '(3 * z + 2 * x * y))
+(test-case (make-sum (make-product 'a 'b)
+ (make-product 'c (make-sum 'd 1) 'e)
+ (make-product (make-sum 'f 2) (make-sum 'g 3) 'h))
+ '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
+(test-case (make-product 5 'x) '(5 * x))
+(test-case (make-product 5 2) 10)
+(test-case (make-product 0 'x) 0)
+(test-case (make-product 5 2 'x) '(10 * x))
+(test-case (make-product 5 1/5 'x) 'x)
+(test-case (make-product 5 1/5 'x 'y) '(x * y))
+(test-case (make-sum (make-sum -5 6 'x) 'y (make-sum -3 3))
+ '(x + 1 + y)) ;; notice that the constant 1 is not right-most
+(test-case (make-product (make-sum 2 4 (make-product 3 -2)) (make-product 4 'y)) 0)
+(test-case (make-sum (make-product 5 'x)
+ (make-product 3 'y)
+ (make-product 2 'y)
+ (make-product 2 3))
+ '(5 * x + 3 * y + 2 * y + 6))
+(test-case (make-sum (make-product 5 'x)
+ (make-product 0 'y)
+ (make-product (make-sum 5 -5) 'x)
+ (make-product 4 'z)
+ (make-sum -3 -3)
+ (make-product 2 3))
+ '(5 * x + 4 * z))
+
+(test-case (addend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 5)) 'a)
+(test-case (addend (make-sum (make-product '3 'x) (make-product 4 'y))) '(3 * x))
+(test-case (addend (make-sum 4 (make-product 1 'y 'x (make-sum 1 'z)) (make-product 2 2))) '(y * x * (z + 1)))
+(test-case (addend '(2 * x * y + 4)) '(2 * x * y))
+(test-case (augend (make-sum 1 'x)) 1)
+(test-case (augend (make-sum 1 5 'x)) 6)
+(test-case (augend (make-sum 1 5 'x 'y)) '(y + 6))
+(test-case (augend (make-sum -3 3 'x 'y)) 'y)
+(test-case (augend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 5)) '(b + c + d + -2))
+(test-case (augend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 4 3)) '(b + c + d))
+(test-case (augend (make-sum (make-product 5 'x)
+ (make-product 3 'y)
+ 2 5 -4))
+ '(3 * y + 3))
+(test-case (augend (make-sum (make-product 5 'x)
+ (make-product 2 0 'y)
+ (make-product (make-sum 5 -5) 'x)
+ (make-product (make-sum 2 4 -6) 'y)
+ (make-product (make-product 0 1) 'z)
+ (make-product 4 'z)
+ -3 -2 -1
+ (make-product 2 3)))
+ '(4 * z))
+
+(test-case (multiplier (make-product (make-product 5 4 'x (make-sum 1 'y))
+ (make-sum 2 'z)))
+ '(20 * x * (y + 1)))
+(test-case (multiplier (make-product (make-sum 5 6 4 -2)
+ 'x 'y
+ (make-sum 1 -3 3)))
+ 13)
+(test-case (multiplicand (make-product 5 'x)) 'x)
+(test-case (multiplicand (make-product 5 'x 'y 'z)) '(x * y * z))
+(test-case (multiplicand (make-product 5 'x 2 -3 'y)) '(x * y))
+(test-case (multiplicand (make-product (make-sum 5 6 4 -2)
+ 'x 'y
+ (make-sum 1 -3 3)))
+ '(x * y))
+
+(test-case (deriv '(* x y (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3))))
blob - /dev/null
blob + 7ecac9b8e9145b03f382baf87565ca8a9aa2a84d (mode 644)
--- /dev/null
+++ ex2-58b.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp) (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp) (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works?
+
+(define (sum? x)
+ (and (not (number? x))
+ (not (variable? x))
+ (not (null? (cdr x)))
+ (or (eq? (cadr x) '+)
+ (sum? (cddr x)))))
+;; sum?
+;; (newline)
+;; (display "sum??")
+;; (newline)
+;; (test-case (sum? '(5 + x)) #t)
+;; (test-case (sum? '(5 * x + 3)) #t)
+;; (test-case (sum? '(8 * x)) #f)
+;; (test-case (sum? 5) #f)
+;; (test-case (sum? '(5 * x + 8 * y)) #t)
+;; (test-case (sum? '(y * ((5 * x) + 3) + 2)) #t)
+
+;; an expression is a product if it is not a sum and contains a * sign somewhere in the top 'level' of a list
+(define (product? x)
+ (and (not (number? x))
+ (not (variable? x))
+ (not (sum? x))
+ (not (null? (cdr x)))
+ (or (eq? (cadr x) '*)
+ (product? (cddr x)))))
+;; (newline)
+;; (display "product?")
+;; (newline)
+;; (test-case (product? '(2 * x * y + 4)) #f)
+;; (test-case (product? '(x * y * z)) #t)
+;; (test-case (product? '((x + 1) * y)) #t)
+;; (test-case (product? '((x + (3 * z) * y) + (5 * z * (3 * y + 5)))) #f)
+;; (test-case (product? '((x + 3 * z * y) * y + 5)) #f)
+
+;; If the first operation is +, we return the first element in the list
+;; Otherwise, we join the first two elements to the addend of the rest
+;; of the list.
+(define (addend s)
+ (if (eq? '+ (cadr s))
+ (car s)
+;; we do not test if (cadddr s) is a number or variable because it might
+;; be a single nested list
+ (if (eq? (cadddr s) '+)
+ (list (car s) (cadr s) (addend (cddr s)))
+ (cons (car s)
+ (cons (cadr s)
+ (addend (cddr s)))))))
+;; (newline)
+;; (display "addend")
+;; (newline)
+;; (test-case (addend '(a + b + c)) 'a)
+;; (test-case (addend '(3 * x + 4 * y)) '(3 * x))
+;; (test-case (addend '(x * y * (z + 1) + (2 * 2))) '(x * y * (z + 1)))
+;; (test-case (addend '(2 * x * y + 4)) '(2 * x * y))
+;; (test-case (addend '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
+;; '((y + 1) * (y + 2)))
+;; (test-case (addend '((y + 1) * (y + 2) * (y + 3) + 2 * ((3 * y) * 2) + 1))
+;; '((y + 1) * (y + 2) * (y + 3)))
+
+;; If the first operation is +, we return the either the third element of the list if it is a single expression, or the rest of the list if there are more elements.
+(define (augend s)
+ (if (eq? '+ (cadr s))
+ (if (null? (cdddr s))
+ (caddr s)
+ (cddr s))
+ (augend (cddr s))))
+;; (newline)
+;; (display "augend")
+;; (newline)
+;; (test-case (augend '(x + 6)) '6)
+;; (test-case (augend '(x + y + 6)) '(y + 6))
+;; (test-case (augend '(x + y * x)) '(y * x))
+;; (test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5))
+;; (test-case (augend '(5 * x + 3 * y + 3))
+;; '(3 * y + 3))
+;; (test-case (augend '(5 * x + (y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
+;; '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
+
+(define (multiplier p)
+ (car p))
+;; (newline)
+;; (display "multiplier")
+;; (newline)
+;; (test-case (multiplier '(5 * x)) 5)
+;; (test-case (multiplier '(x * (x + 2))) 'x)
+;; (test-case (multiplier '((x + 1) * (x + 2) * (x + 3))) '(x + 1))
+;; (test-case (multiplier '((5 * x + 2) * 3)) '(5 * x + 2))
+;; (test-case (multiplier '((((x + 1) * (x + 2)) + 5) * (x + 3))) '(((x + 1) * (x + 2)) + 5))
+;; (test-case (multiplier '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(y * (x + 5 * (y + 2)) + 4))
+;; (test-case (multiplier '((x + y + z) * (x + y))) '(x + y + z))
+
+(define (multiplicand p)
+ (if (null? (cdddr p))
+ (caddr p)
+ (cddr p)))
+;; (newline)
+;; (display "multiplicand")
+;; (newline)
+;; (test-case (multiplicand '(5 * x)) 'x)
+;; (test-case (multiplicand '(x * (x + 2))) '(x + 2))
+;; (test-case (multiplicand '((x + 1) * (x + 2) * (x + 3))) '((x + 2) * (x + 3)))
+;; (test-case (multiplicand '((5 * x + 2) * y)) 'y)
+;; (test-case (multiplicand '((((x + 1) * (x + 2)) + 5) * (x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) '((x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1)))
+;; (test-case (multiplicand '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(x * z))
+;; (test-case (multiplicand '((x + y + z) * (x + y))) '(x + y))
+
+;; given a list of items to sum, check to see if any of the items are sums.
+;; If they are, return a new list with the addend and augends as separate expressions
+(define (break-sums exps)
+ (if (null? exps)
+ '()
+ (let ((x (car exps)))
+ (if (sum? x)
+ (cons (addend x)
+ (break-sums (cons (augend x) (cdr exps))))
+ (cons x (break-sums (cdr exps)))))))
+
+;; (newline)
+;; (display "break-sums")
+;; (newline)
+;; (test-case (break-sums '((x + 5) x 3)) '(x 5 x 3))
+;; (test-case (break-sums '((x + (x + 5)) x 3)) '(x x 5 x 3))
+;; (test-case (break-sums '((x + 5 + 2 * x * y) (x * y + 5) (a + 2 + 3 * x) (x + a * b * c + 7))) '(x 5 (2 * x * y) (x * y) 5 a 2 (3 * x) x (a * b * c) 7))
+
+;; interpolate '+ signs between expressions
+(define (add-plus-signs exps)
+ (if (null? exps)
+ '() ;; this should never execute
+ (let ((x (car exps))
+ (remnant (cdr exps)))
+ (cond ((null? remnant)
+ (if (or (number? x)
+ (variable? x))
+ (list x)
+ x)) ;; when x is a one-element list like '((x * y))
+ ((or (number? x)
+ (variable? x))
+ (cons x (cons '+ (add-plus-signs remnant))))
+ ((sum? x)
+ (error "unexpected sum"))
+ ((product? x)
+ (cons (multiplier x)
+ (cons '*
+ (add-plus-signs (cons (multiplicand x) remnant)))))
+ (else (error "expression type not yet implemented"))))))
+;; (newline)
+;; (display "add-plus-signs")
+;; (newline)
+;; (test-case (add-plus-signs '()) '())
+;; (test-case (add-plus-signs '(1)) '(1))
+;; (test-case (add-plus-signs '(x y z 4)) '(x + y + z + 4))
+;; (test-case (add-plus-signs '((x * y))) '(x * y))
+;; (test-case (add-plus-signs '((x * y) 5)) '(x * y + 5))
+;; (test-case (add-plus-signs '(((x * y) * (x + 1)) (5 * (x + 1)))) '((x * y) * (x + 1) + 5 * (x + 1)))
+;; (test-case (add-plus-signs '(((x * y + 2) * (y + 5)) a b (((a * b + 2) * c * (d + 1)) * (e + 4))))
+;; '((x * y + 2) * (y + 5) + a + b + ((a * b + 2) * c * (d + 1)) * (e + 4)))
+
+;; If the term is:
+;; a number or a variable: we deal with it is without adding or removing any parentheses
+;; a product: we must remove the parentheses around the product but not tamper with parentheses within the multiplier or multiplicand. We must deal with the product as a single term.
+;; a sum: we must remove the parentheses around the sum (but we can optionally leave the addend's and potentially multiple augends' existing parentheses intact). We must then deal with the addend and potentially multiple augends as separate terms
+(define (make-sum . exps)
+ (let* ((terms (break-sums exps))
+ (nums (filter number? terms))
+ (non-nums (filter (lambda (exp) (not (number? exp))) terms))
+ (sum-of-nums (fold-right + 0 nums)))
+ (cond ((null? non-nums) sum-of-nums)
+ ((and (= sum-of-nums 0)
+ (null? (cdr non-nums))) (car non-nums))
+ ((= sum-of-nums 0) (add-plus-signs non-nums))
+ (else (add-plus-signs (append non-nums (list sum-of-nums)))))))
+;; (newline)
+;; (display "make-sum")
+;; (newline)
+;; (test-case (make-sum 0 'x) 'x)
+;; (test-case (make-sum 1 2) 3)
+;; (test-case (make-sum 1 'x) '(x + 1))
+;; (test-case (make-sum 'x 'y) '(x + y))
+;; (test-case (make-sum (make-sum -3 'y)
+;; (make-sum 3 'x)) '(y + x))
+;; (make-sum '(y + -3) '(x + 3))
+;; (make-sum 'y -3 'x 3)
+;; (test-case (make-sum -3 'y 3 'x) '(y + x))
+;; (test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d))
+;; (test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum 'z (make-sum 1 'x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials
+;; (test-case (make-sum 4 '(2 * x * y)) '(2 * x * y + 4))
+;; (test-case (make-sum '(3 * z) '(2 * x * y)) '(3 * z + 2 * x * y))
+;; (test-case (make-sum '(a * b) '(c * (d + 1) * e) '((f + 2) * (g + 3) * h)) '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
+
+;; given a list of items to multiply, check to see if any of the items are products.
+;; If they are, return a new list with the multiplier and multiplicands as separate expressions
+(define (break-products exps)
+ (if (null? exps)
+ '()
+ (let ((x (car exps)))
+ (if (product? x)
+ (cons (multiplier x)
+ (break-products (cons (multiplicand x) (cdr exps))))
+ (cons x (break-products (cdr exps)))))))
+
+;; (newline)
+;; (display "break-products")
+;; (newline)
+;; (test-case (break-products '((5 * x) x 3)) '(5 x x 3))
+;; (test-case (break-products '((x * (5 * x)) x 3)) '(x 5 x x 3))
+;; (test-case (break-products '((5 * a * b + x + y) (x * y + 5) (2 * a * b) (x * y))) '((5 * a * b + x + y) (x * y + 5) 2 a b x y))
+
+;; interpolate '* signs between expressions
+(define (add-mult-signs exps)
+ (if (null? exps)
+ '() ;; this should never execute
+ (let ((x (car exps))
+ (remnant (cdr exps)))
+ (cond ((null? remnant)
+ (if (or (number? x)
+ (variable? x)
+ (sum? x))
+ (list x)
+ x)) ;; when x is a one-element list like '((x ** y))
+ ((or (number? x)
+ (variable? x)
+ (sum? x))
+ (cons x (cons '* (add-mult-signs remnant))))
+ ((product? x)
+ (error "unexpected product"))
+ (else (error "expression type not yet implemented"))))))
+;; (newline)
+;; (display "add-mult-signs")
+;; (newline)
+;; (test-case (add-mult-signs '()) '())
+;; (test-case (add-mult-signs '(1)) '(1))
+;; (test-case (add-mult-signs '(4 x y z)) '(4 * x * y * z))
+;; (test-case (add-mult-signs '((x * y))) '(x * y))
+;; (test-case (add-mult-signs '(5 (x + y))) '(5 * (x + y)))
+;; (test-case (add-mult-signs '((x + y) (x + 1) ((2 * x + 1) + 5 * x))) '((x + y) * (x + 1) * ((2 * x + 1) + 5 * x)))
+;; (test-case (add-mult-signs '((x * y + 2) (y + 5) a b (a * b + 2) c (d + 1) (e + 4)))
+;; '((x * y + 2) * (y + 5) * a * b * (a * b + 2) * c * (d + 1) * (e + 4)))
+
+;; If the exp is a:
+;; variable or number, we just multiply without adding any extra parentheses
+;; sum, then we leave the parentheses intact and multiply, treating the sum as a single term
+;; product, then we must remove the parentheses around the product (optionally leaving the multiplier's and potentially multiple multiplicands' parentheses intact). We must deal with the multiplier and potentially multiple multiplicands as separate terms.
+;; (not implemented) a complex expression, we remove the parentheses around the expression and treat it as a single term
+
+(define (make-product . exps)
+ (let* ((terms (break-products exps))
+ (nums (filter number? terms))
+ (non-nums (filter (lambda (exp) (not (number? exp))) terms))
+ (product-of-nums (fold-right * 1 nums)))
+ (cond ((null? non-nums) product-of-nums)
+ ((= product-of-nums 0) 0)
+ ((and (= product-of-nums 1)
+ (null? (cdr non-nums))) (car non-nums))
+ ((= product-of-nums 1) (add-mult-signs non-nums))
+ (else (add-mult-signs (cons product-of-nums non-nums))))))
+
+;; (test-case (make-product 5 '(5 * x)) '(25 * x))
+;; (test-case (make-product 5 'x) '(5 * x))
+;; (test-case (make-product 5 2) 10)
+;; (test-case (make-product 0 'x) 0)
+;; (test-case (make-product 5 2 'x) '(10 * x))
+;; (test-case (make-product 5 1/5 'x 'y) '(x * y))
+;; (test-case (make-product (make-product 'x 5) (make-product 'x 3 (make-product 1/15 'y 'z)) 'x) '(x * x * y * z * x))
+;; (test-case (make-product '(x + 3) 'y) '((x + 3) * y))
+;; (test-case (make-product (make-sum 5 'x)
+;; (make-product 'x 'y)
+;; (make-sum 'z 2))
+;; '((x + 5) * x * y * (z + 2)))
+;; (test-case (make-product
+;; (make-sum (make-product 5 'x)
+;; (make-product 3 'y))
+;; (make-sum (make-product 2 'y)
+;; (make-product 2 3))
+;; (make-sum (make-sum 'x 4) (make-product 3 'y)))
+;; '((5 * x + 3 * y) * (2 * y + 6) * (x + 3 * y + 4)))
+(test-case (make-sum (make-product 'a 'b)
+ (make-product 'c (make-sum 'd 1) 'e)
+ (make-product (make-sum 'f 2) (make-sum 'g 3) 'h))
+ '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
+(test-case (make-product (make-sum 5 'x)
+ (make-product 'x 'y)
+ (make-sum 'z 2))
+ '((x + 5) * x * y * (z + 2)))
+
+
+
+
+(test-case (deriv '(x * y * (x + 3)) 'x) '(x * y + y * (x + 3)))
blob - /dev/null
blob + 5cc4dad5e705fdba7a9b3c72d9a7fe60c2d5f0b3 (mode 644)
--- /dev/null
+++ ex2-58b.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp) (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp) (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works?
+
+(define (sum? x)
+ (and (not (number? x))
+ (not (variable? x))
+ (not (null? (cdr x)))
+ (or (eq? (cadr x) '+)
+ (sum? (cddr x)))))
+;; sum?
+;; (newline)
+;; (display "sum??")
+;; (newline)
+;; (test-case (sum? '(5 + x)) #t)
+;; (test-case (sum? '(5 * x + 3)) #t)
+;; (test-case (sum? '(8 * x)) #f)
+;; (test-case (sum? 5) #f)
+;; (test-case (sum? '(5 * x + 8 * y)) #t)
+;; (test-case (sum? '(y * ((5 * x) + 3) + 2)) #t)
+
+;; an expression is a product if it is not a sum and contains a * sign somewhere in the top 'level' of a list
+(define (product? x)
+ (and (not (number? x))
+ (not (variable? x))
+ (not (sum? x))
+ (not (null? (cdr x)))
+ (or (eq? (cadr x) '*)
+ (product? (cddr x)))))
+;; (newline)
+;; (display "product?")
+;; (newline)
+;; (test-case (product? '(2 * x * y + 4)) #f)
+;; (test-case (product? '(x * y * z)) #t)
+;; (test-case (product? '((x + 1) * y)) #t)
+;; (test-case (product? '((x + (3 * z) * y) + (5 * z * (3 * y + 5)))) #f)
+;; (test-case (product? '((x + 3 * z * y) * y + 5)) #f)
+
+;; If the first operation is +, we return the first element in the list
+;; Otherwise, we join the first two elements to the addend of the rest
+;; of the list.
+(define (addend s)
+ (if (eq? '+ (cadr s))
+ (car s)
+;; we do not test if (cadddr s) is a number or variable because it might
+;; be a single nested list
+ (if (eq? (cadddr s) '+)
+ (list (car s) (cadr s) (addend (cddr s)))
+ (cons (car s)
+ (cons (cadr s)
+ (addend (cddr s)))))))
+;; (newline)
+;; (display "addend")
+;; (newline)
+;; (test-case (addend '(a + b + c)) 'a)
+;; (test-case (addend '(3 * x + 4 * y)) '(3 * x))
+;; (test-case (addend '(x * y * (z + 1) + (2 * 2))) '(x * y * (z + 1)))
+;; (test-case (addend '(2 * x * y + 4)) '(2 * x * y))
+;; (test-case (addend '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
+;; '((y + 1) * (y + 2)))
+;; (test-case (addend '((y + 1) * (y + 2) * (y + 3) + 2 * ((3 * y) * 2) + 1))
+;; '((y + 1) * (y + 2) * (y + 3)))
+
+;; If the first operation is +, we return the either the third element of the list if it is a single expression, or the rest of the list if there are more elements.
+(define (augend s)
+ (if (eq? '+ (cadr s))
+ (if (null? (cdddr s))
+ (caddr s)
+ (cddr s))
+ (augend (cddr s))))
+;; (newline)
+;; (display "augend")
+;; (newline)
+;; (test-case (augend '(x + 6)) '6)
+;; (test-case (augend '(x + y + 6)) '(y + 6))
+;; (test-case (augend '(x + y * x)) '(y * x))
+;; (test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5))
+;; (test-case (augend '(5 * x + 3 * y + 3))
+;; '(3 * y + 3))
+;; (test-case (augend '(5 * x + (y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
+;; '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
+
+(define (multiplier p)
+ (car p))
+;; (newline)
+;; (display "multiplier")
+;; (newline)
+;; (test-case (multiplier '(5 * x)) 5)
+;; (test-case (multiplier '(x * (x + 2))) 'x)
+;; (test-case (multiplier '((x + 1) * (x + 2) * (x + 3))) '(x + 1))
+;; (test-case (multiplier '((5 * x + 2) * 3)) '(5 * x + 2))
+;; (test-case (multiplier '((((x + 1) * (x + 2)) + 5) * (x + 3))) '(((x + 1) * (x + 2)) + 5))
+;; (test-case (multiplier '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(y * (x + 5 * (y + 2)) + 4))
+;; (test-case (multiplier '((x + y + z) * (x + y))) '(x + y + z))
+
+(define (multiplicand p)
+ (if (null? (cdddr p))
+ (caddr p)
+ (cddr p)))
+;; (newline)
+;; (display "multiplicand")
+;; (newline)
+;; (test-case (multiplicand '(5 * x)) 'x)
+;; (test-case (multiplicand '(x * (x + 2))) '(x + 2))
+;; (test-case (multiplicand '((x + 1) * (x + 2) * (x + 3))) '((x + 2) * (x + 3)))
+;; (test-case (multiplicand '((5 * x + 2) * y)) 'y)
+;; (test-case (multiplicand '((((x + 1) * (x + 2)) + 5) * (x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) '((x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1)))
+;; (test-case (multiplicand '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(x * z))
+;; (test-case (multiplicand '((x + y + z) * (x + y))) '(x + y))
+
+;; given a list of items to sum, check to see if any of the items are sums.
+;; If they are, return a new list with the addend and augends as separate expressions
+(define (break-sums exps)
+ (if (null? exps)
+ '()
+ (let ((x (car exps)))
+ (if (sum? x)
+ (cons (addend x)
+ (break-sums (cons (augend x) (cdr exps))))
+ (cons x (break-sums (cdr exps)))))))
+
+;; (newline)
+;; (display "break-sums")
+;; (newline)
+;; (test-case (break-sums '((x + 5) x 3)) '(x 5 x 3))
+;; (test-case (break-sums '((x + (x + 5)) x 3)) '(x x 5 x 3))
+;; (test-case (break-sums '((x + 5 + 2 * x * y) (x * y + 5) (a + 2 + 3 * x) (x + a * b * c + 7))) '(x 5 (2 * x * y) (x * y) 5 a 2 (3 * x) x (a * b * c) 7))
+
+;; interpolate '+ signs between expressions
+(define (add-plus-signs exps)
+ (if (null? exps)
+ '() ;; this should never execute
+ (let ((x (car exps))
+ (remnant (cdr exps)))
+ (cond ((null? remnant) (if (or (number? x)
+ (variable? x))
+ (list x)
+ x)) ;; when x is a one-element list like '((x * y))
+ ((or (number? x)
+ (variable? x)) (cons x (cons '+ (add-plus-signs remnant))))
+ ((sum? x) (error "unexpected sum"))
+;; if x is a product or some other complicated expression
+ ((product? x) (cons (multiplier x)
+ (cons '*
+ (add-plus-signs (cons (multiplicand x) remnant)))))
+ ;; (cons (multiplicand x)
+ ;; (cons '+ (add-plus-signs remnant))))))
+ (else (error "expression type not yet implemented"))))))
+;; (newline)
+;; (display "add-plus-signs")
+;; (newline)
+;; (test-case (add-plus-signs '()) '())
+;; (test-case (add-plus-signs '(1)) '(1))
+;; (test-case (add-plus-signs '(x y z 4)) '(x + y + z + 4))
+;; (test-case (add-plus-signs '((x * y))) '(x * y))
+;; (test-case (add-plus-signs '((x * y) 5)) '(x * y + 5))
+;; (test-case (add-plus-signs '(((x * y) * (x + 1)) (5 * (x + 1)))) '((x * y) * (x + 1) + 5 * (x + 1)))
+;; (test-case (add-plus-signs '(((x * y + 2) * (y + 5)) a b (((a * b + 2) * c * (d + 1)) * (e + 4))))
+;; '((x * y + 2) * (y + 5) + a + b + ((a * b + 2) * c * (d + 1)) * (e + 4)))
+
+;; If the term is:
+;; a number or a variable: we deal with it is without adding or removing any parentheses
+;; a product: we must remove the parentheses around the product but not tamper with parentheses within the multiplier or multiplicand. We must deal with the product as a single term.
+;; a sum: we must remove the parentheses around the sum (but we can optionally leave the addend's and potentially multiple augends' existing parentheses intact). We must then deal with the addend and potentially multiple augends individually.
+
+(define (make-sum . exps)
+ (let* ((terms (break-sums exps))
+ (nums (filter number? terms))
+ (non-nums (filter (lambda (exp) (not (number? exp))) terms))
+ (sum-of-nums (fold-right + 0 nums)))
+ (cond ((null? non-nums) sum-of-nums)
+ ((and (= sum-of-nums 0)
+ (null? (cdr non-nums))) (car non-nums))
+ ((= sum-of-nums 0) (add-plus-signs non-nums))
+ (else (add-plus-signs (append non-nums (list sum-of-nums)))))))
+(newline)
+(display "make-sum")
+(newline)
+(test-case (make-sum 0 'x) 'x)
+(test-case (make-sum 1 2) 3)
+(test-case (make-sum 1 'x) '(x + 1))
+(test-case (make-sum 'x 'y) '(x + y))
+(test-case (make-sum (make-sum -3 'y)
+ (make-sum 3 'x)) '(y + x))
+(make-sum '(y + -3) '(x + 3))
+(make-sum 'y -3 'x 3)
+(test-case (make-sum -3 'y 3 'x) '(y + x))
+(test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d))
+(test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum 'z (make-sum 1 'x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials
+(test-case (make-sum 4 '(2 * x * y)) '(2 * x * y + 4))
+(test-case (make-sum '(3 * z) '(2 * x * y)) '(3 * z + 2 * x * y))
+(test-case (make-sum '(a * b) '(c * (d + 1) * e) '((f + 2) * (g + 3) * h)) '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
+
+;; (test-case (make-product (make-sum 5 'x)
+;; (make-product 'x 'y)
+;; (make-sum 'z 2))
+;; '((5 + x) * x * y * (z + 2)))
+;; ;; if we are dealing with sums, then we must add parentheses; otherwise, omit parentheses
+;; (test-case (make-sum (make-sum -5 6 'x)
+;; 'y
+;; (make-sum -3 3))
+;; '(x + 1 + y)) ;; notice that the constant 1 is not right-most
+;; (test-case (make-product (make-sum 2 4 (make-product 3 -2))
+;; (make-product 4 'y)) 0)
+;; (test-case (make-sum (make-product 5 'x)
+;; (make-product 3 'y)
+;; (make-product 2 'y)
+;; (make-product 2 3))
+;; '(5 * x + 3 * y + 2 * y + 6))
+;; (test-case (make-sum (make-product 5 'x 'y)
+;; (make-product 4 'a 'b 'c))
+;; '(5 * x * y + 4 * a * b * c))
+
+
+(define (make-product . exps)
+ (let* ((nums (filter number? exps))
+ (non-nums (filter (lambda (exp) (not (number? exp))) exps))
+ (product-of-nums (fold-right * 1 nums)))
+ (cond ((null? non-nums) product-of-nums)
+ ((= product-of-nums 0) 0)
+ ((and (= product-of-nums 1)
+ (null? (cdr non-nums))) (car non-nums))
+ ((= product-of-nums 1) (add-mult-signs non-nums))
+ (else (add-mult-signs (cons product-of-nums non-nums))))))
+
+(test-case (make-product 5 'x) '(5 * x))
+(test-case (make-product 5 2) 10)
+(test-case (make-product 0 'x) 0)
+(test-case (make-product 5 2 'x) '(10 * x))
+(test-case (make-product 5 1/5 'x 'y) '(x * y))
+(test-case (make-product (make-product 'x 5) (make-product 'x 3 (make-product 1/15 'y 'z)) 'x) '(x * x * y * z * x))
+(test-case (make-product '(x + 3) 'y) '((x + 3) * y))
+(test-case
+
+If the exp is a:
+variable or number, we just multiply without adding any extra parentheses
+sum, then we must put parentheses around it and then multiply
+product, then we just multiply without adding any extra parentheses
+a complex expression, we just multiply without adding any extra parenthese around it
+
+;; (define (add-mult-signs exps)
+;; (cond ((null? exps) '())
+;; ((null? (cdr exps)) exps)
+;; (else (cons (car exps)
+;; (cons '*
+;; (add-mult-signs (cdr exps)))))))
+
+
+
+
+'((2 * y + 3 * x) (4 * z + 5 * a))
+;; if there is no sum in exp, remove the parentheses
+
+
+
+
+
+
+
+
+
+
+
+
+
+;; make-sum
+(test-case (make-sum (make-product 2 'x 'y) 4) '(2 * x * y + 4))
+(test-case (make-sum 4 (make-product 2 'x 'y)) '(4 + 2 * x * y))
+(test-case (make-sum (make-product 3 'z) (make-product 2 'x 'y)) '(3 * z + 2 * x * y))
+(test-case (make-sum (make-product 'a 'b)
+ (make-product 'c (make-sum 'd 1) 'e)
+ (make-product (make-sum 'f 2) (make-sum 'g 3) 'h))
+ '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
+(test-case (make-product 5 'x) '(5 * x))
+(test-case (make-product 5 2) 10)
+(test-case (make-product 0 'x) 0)
+(test-case (make-product 5 2 'x) '(10 * x))
+(test-case (make-product 5 1/5 'x 'y) '(x * y))
+(test-case (make-product 5 (make-product 'x 'y) 'z) '(5 * x * y * z))
+(test-case (make-product (make-sum 5 'x)
+ (make-product 'x 'y)
+ (make-sum 'z 2))
+ '((5 + x) * x * y * (z + 2)))
+;; if we are dealing with sums, then we must add parentheses; otherwise, omit parentheses
+(test-case (make-sum (make-sum -5 6 'x)
+ 'y
+ (make-sum -3 3))
+ '(x + 1 + y)) ;; notice that the constant 1 is not right-most
+(test-case (make-product (make-sum 2 4 (make-product 3 -2))
+ (make-product 4 'y)) 0)
+(test-case (make-sum (make-product 5 'x)
+ (make-product 3 'y)
+ (make-product 2 'y)
+ (make-product 2 3))
+ '(5 * x + 3 * y + 2 * y + 6))
+(test-case (make-sum (make-product 5 'x 'y)
+ (make-product 4 'a 'b 'c))
+ '(5 * x * y + 4 * a * b * c))
+
+
+(test-case (multiplier '(20 * x * ( (make-product (make-product 5 4 'x (make-sum 1 'y))
+ (make-sum 2 'z)))
+ '(20 * x * (y + 1)))
+(test-case (multiplier (make-product (make-sum 5 6 4 -2)
+ 'x 'y
+ (make-sum 1 -3 3)))
+ 13)
+(test-case (multiplicand (make-product 5 'x)) 'x)
+(test-case (multiplicand (make-product 5 'x 'y 'z)) '(x * y * z))
+(test-case (multiplicand (make-product 5 'x 2 -3 'y)) '(x * y))
+(test-case (multiplicand (make-product (make-sum 5 6 4 -2)
+ 'x 'y
+ (make-sum 1 -3 3)))
+ '(x * y))
+
+(test-case (deriv '(* x y (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3))))
+
+
+;; (define (make-sum . exps)
+;; (let* ((nums (filter number? exps))
+;; (non-nums (filter (lambda (exp) (not (number? exp))) exps))
+;; (sum-of-nums (fold-right + 0 nums)))
+;; (cond ((null? non-nums) sum-of-nums)
+;; ((and (= sum-of-nums 0)
+;; (null? (cdr non-nums))) (car non-nums))
+;; ((= sum-of-nums 0) (add-plus-signs non-nums))
+;; (else (add-plus-signs (append non-nums (list sum-of-nums)))))))
+
+
+
+
+
+
+
+(define (remove-parens exps)
+ (cond ((sum? exps) ...)
+ ...))
+(newline)
+(display "remove-parens")
+(newline)
+(test-case (remove-parens '(0 x)) '(0 x))
+(test-case (remove-parents
+(make-sum '(y + -3)
+ '(x + 3)
+ '(y + x + 3))
+(test-case (make-sum -3 'y 3 'x) '(y + x))
+(test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d))
+(test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum z (make-sum 1 x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials
+
+;; (test-case (remove-parens '((
+
+;; (define (make-sum . exps)
+;; (let* ((terms (append exps))
+;; (nums (filter number? terms))
+;; (non-nums (filter (lambda (exp) (not (number? exp))) terms))
+;; (sum-of-nums (fold-right + 0 nums)))
+;; (cond ((null? non-nums) sum-of-nums)
+;; ((and (= sum-of-nums 0)
+;; (null? (cdr non-nums))) (car non-nums))
+;; ((= sum-of-nums 0) (add-signs non-nums '+))
+;; (else (add-plus-signs (append non-nums (list sum-of-nums)))))))
+
+;;given a list of expressions to add, remove unnecessary groupings
+(define (extract-terms exps)
+ (if (null? exps)
+ '()
+ (let ((first-exp (car exps)))
+ (if (sum? first-exp)
+ (cons (addend first-exp)
+ (append (extract-terms (augend first-exp))
+ (extract-terms (cdr exps))))))))
+ (cons first-exp (extract-terms (cdr exprs)))
+
+
+
+(test-case (extract-terms '((y + -3) (x + 3))) '(y
+
+(test-case (make-sum (make-sum -3 'y)
+ (make-sum 3 'x)) '(y + x + 3))
+(make-sum '(y + -3) '(x + 3))
+(make-sum 'y -3 'x 3)
+(test-case (make-sum -3 'y 3 'x) '(y + x))
+(test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d))
+(test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum z (make-sum 1 x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials
+
+(test-case (make-sum (make-product 2 'x 'y) 4) '(2 * x * y + 4))
+(test-case (make-sum 4 (make-product 2 'x 'y)) '(4 + 2 * x * y))
+(test-case (make-sum (make-product 3 'z) (make-product 2 'x 'y)) '(3 * z + 2 * x * y))
+(test-case (make-sum (make-product 'a 'b)
+ (make-product 'c (make-sum 'd 1) 'e)
+ (make-product (make-sum 'f 2) (make-sum 'g 3) 'h))
+ '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
+(test-case (make-product 5 'x) '(5 * x))
+(test-case (make-product 5 2) 10)
+(test-case (make-product 0 'x) 0)
+(test-case (make-product 5 2 'x) '(10 * x))
+(test-case (make-product 5 1/5 'x 'y) '(x * y))
+(test-case (make-product 5 (make-product 'x 'y) 'z) '(5 * x * y * z))
+(test-case (make-product (make-sum 5 'x)
+ (make-product 'x 'y)
+ (make-sum 'z 2))
+ '((5 + x) * x * y * (z + 2)))
+;; if we are dealing with sums, then we must add parentheses; otherwise, omit parentheses
+(test-case (make-sum (make-sum -5 6 'x)
+ 'y
+ (make-sum -3 3))
+ '(x + 1 + y)) ;; notice that the constant 1 is not right-most
+(test-case (make-product (make-sum 2 4 (make-product 3 -2))
+ (make-product 4 'y)) 0)
+(test-case (make-sum (make-product 5 'x)
+ (make-product 3 'y)
+ (make-product 2 'y)
+ (make-product 2 3))
+ '(5 * x + 3 * y + 2 * y + 6))
+(test-case (make-sum (make-product 5 'x 'y)
+ (make-product 4 'a 'b 'c))
+ '(5 * x * y + 4 * a * b * c))
blob - /dev/null
blob + c990407070822ff655fd1ff7456c92885402f559 (mode 644)
--- /dev/null
+++ ex2-58c.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp) (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp) (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works?
+
+(define (sum? x)
+ (and (not (number? x))
+ (not (variable? x))
+ (not (null? (cdr x)))
+ (or (eq? (cadr x) '+)
+ (sum? (cddr x)))))
+;; sum?
+;; (newline)
+;; (display "sum??")
+;; (newline)
+;; (test-case (sum? '(5 + x)) #t)
+;; (test-case (sum? '(5 * x + 3)) #t)
+;; (test-case (sum? '(8 * x)) #f)
+;; (test-case (sum? 5) #f)
+;; (test-case (sum? '(5 * x + 8 * y)) #t)
+;; (test-case (sum? '(y * ((5 * x) + 3) + 2)) #t)
+
+;; an expression is a product if it is not a sum and contains a * sign somewhere in the top 'level' of a list
+(define (product? x)
+ (and (not (number? x))
+ (not (variable? x))
+ (not (sum? x))
+ (not (null? (cdr x)))
+ (or (eq? (cadr x) '*)
+ (product? (cddr x)))))
+;; (newline)
+;; (display "product?")
+;; (newline)
+;; (test-case (product? '(2 * x * y + 4)) #f)
+;; (test-case (product? '(x * y * z)) #t)
+;; (test-case (product? '((x + 1) * y)) #t)
+;; (test-case (product? '((x + (3 * z) * y) + (5 * z * (3 * y + 5)))) #f)
+;; (test-case (product? '((x + 3 * z * y) * y + 5)) #f)
+
+;; If the first operation is +, we return the first element in the list
+;; Otherwise, we join the first two elements to the addend of the rest
+;; of the list.
+(define (addend s)
+ (if (eq? '+ (cadr s))
+ (car s)
+;; we do not test if (cadddr s) is a number or variable because it might
+;; be a single nested list
+ (if (eq? (cadddr s) '+)
+ (list (car s) (cadr s) (addend (cddr s)))
+ (cons (car s)
+ (cons (cadr s)
+ (addend (cddr s)))))))
+;; (newline)
+;; (display "addend")
+;; (newline)
+;; (test-case (addend '(a + b + c)) 'a)
+;; (test-case (addend '(3 * x + 4 * y)) '(3 * x))
+;; (test-case (addend '(x * y * (z + 1) + (2 * 2))) '(x * y * (z + 1)))
+;; (test-case (addend '(2 * x * y + 4)) '(2 * x * y))
+;; (test-case (addend '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
+;; '((y + 1) * (y + 2)))
+;; (test-case (addend '((y + 1) * (y + 2) * (y + 3) + 2 * ((3 * y) * 2) + 1))
+;; '((y + 1) * (y + 2) * (y + 3)))
+
+;; If the first operation is +, we return the either the third element of the list if it is a single expression, or the rest of the list if there are more elements.
+(define (augend s)
+ (if (eq? '+ (cadr s))
+ (if (null? (cdddr s))
+ (caddr s)
+ (cddr s))
+ (augend (cddr s))))
+;; (newline)
+;; (display "augend")
+;; (newline)
+;; (test-case (augend '(x + 6)) '6)
+;; (test-case (augend '(x + y + 6)) '(y + 6))
+;; (test-case (augend '(x + y * x)) '(y * x))
+;; (test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5))
+;; (test-case (augend '(5 * x + 3 * y + 3))
+;; '(3 * y + 3))
+;; (test-case (augend '(5 * x + (y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
+;; '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
+
+(define (multiplier p)
+ (car p))
+;; (newline)
+;; (display "multiplier")
+;; (newline)
+;; (test-case (multiplier '(5 * x)) 5)
+;; (test-case (multiplier '(x * (x + 2))) 'x)
+;; (test-case (multiplier '((x + 1) * (x + 2) * (x + 3))) '(x + 1))
+;; (test-case (multiplier '((5 * x + 2) * 3)) '(5 * x + 2))
+;; (test-case (multiplier '((((x + 1) * (x + 2)) + 5) * (x + 3))) '(((x + 1) * (x + 2)) + 5))
+;; (test-case (multiplier '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(y * (x + 5 * (y + 2)) + 4))
+;; (test-case (multiplier '((x + y + z) * (x + y))) '(x + y + z))
+
+(define (multiplicand p)
+ (if (null? (cdddr p))
+ (caddr p)
+ (cddr p)))
+;; (newline)
+;; (display "multiplicand")
+;; (newline)
+;; (test-case (multiplicand '(5 * x)) 'x)
+;; (test-case (multiplicand '(x * (x + 2))) '(x + 2))
+;; (test-case (multiplicand '((x + 1) * (x + 2) * (x + 3))) '((x + 2) * (x + 3)))
+;; (test-case (multiplicand '((5 * x + 2) * y)) 'y)
+;; (test-case (multiplicand '((((x + 1) * (x + 2)) + 5) * (x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) '((x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1)))
+;; (test-case (multiplicand '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(x * z))
+;; (test-case (multiplicand '((x + y + z) * (x + y))) '(x + y))
+
+;; given a list of items to sum, check to see if any of the items are sums.
+;; If they are, return a new list with the addend and augends as separate expressions
+(define (break-sums exps)
+ (if (null? exps)
+ '()
+ (let ((x (car exps)))
+ (if (sum? x)
+ (cons (addend x)
+ (break-sums (cons (augend x) (cdr exps))))
+ (cons x (break-sums (cdr exps)))))))
+
+;; (newline)
+;; (display "break-sums")
+;; (newline)
+;; (test-case (break-sums '((x + 5) x 3)) '(x 5 x 3))
+;; (test-case (break-sums '((x + (x + 5)) x 3)) '(x x 5 x 3))
+;; (test-case (break-sums '((x + 5 + 2 * x * y) (x * y + 5) (a + 2 + 3 * x) (x + a * b * c + 7))) '(x 5 (2 * x * y) (x * y) 5 a 2 (3 * x) x (a * b * c) 7))
+
+;; interpolate '+ signs between expressions
+(define (add-plus-signs exps)
+ (if (null? exps)
+ '() ;; this should never execute
+ (let ((x (car exps))
+ (remnant (cdr exps)))
+ (cond ((null? remnant)
+ (if (or (number? x)
+ (variable? x))
+ (list x)
+ x)) ;; when x is a one-element list like '((x * y))
+ ((or (number? x)
+ (variable? x))
+ (cons x (cons '+ (add-plus-signs remnant))))
+ ((sum? x)
+ (error "unexpected sum"))
+ ((product? x)
+ (cons (multiplier x)
+ (cons '*
+ (add-plus-signs (cons (multiplicand x) remnant)))))
+ (else (error "expression type not yet implemented"))))))
+;; (newline)
+;; (display "add-plus-signs")
+;; (newline)
+;; (test-case (add-plus-signs '()) '())
+;; (test-case (add-plus-signs '(1)) '(1))
+;; (test-case (add-plus-signs '(x y z 4)) '(x + y + z + 4))
+;; (test-case (add-plus-signs '((x * y))) '(x * y))
+;; (test-case (add-plus-signs '((x * y) 5)) '(x * y + 5))
+;; (test-case (add-plus-signs '(((x * y) * (x + 1)) (5 * (x + 1)))) '((x * y) * (x + 1) + 5 * (x + 1)))
+;; (test-case (add-plus-signs '(((x * y + 2) * (y + 5)) a b (((a * b + 2) * c * (d + 1)) * (e + 4))))
+;; '((x * y + 2) * (y + 5) + a + b + ((a * b + 2) * c * (d + 1)) * (e + 4)))
+
+;; If the term is:
+;; a number or a variable: we deal with it is without adding or removing any parentheses
+;; a product: we must remove the parentheses around the product but not tamper with parentheses within the multiplier or multiplicand. We must deal with the product as a single term.
+;; a sum: we must remove the parentheses around the sum (but we can optionally leave the addend's and potentially multiple augends' existing parentheses intact). We must then deal with the addend and potentially multiple augends as separate terms
+(define (make-sum . exps)
+ (let* ((terms (break-sums exps))
+ (nums (filter number? terms))
+ (non-nums (filter (lambda (exp) (not (number? exp))) terms))
+ (sum-of-nums (fold-right + 0 nums)))
+ (cond ((null? non-nums) sum-of-nums)
+ ((and (= sum-of-nums 0)
+ (null? (cdr non-nums))) (car non-nums))
+ ((= sum-of-nums 0) (add-plus-signs non-nums))
+ (else (add-plus-signs (append non-nums (list sum-of-nums)))))))
+;; (newline)
+;; (display "make-sum")
+;; (newline)
+;; (test-case (make-sum 0 'x) 'x)
+;; (test-case (make-sum 1 2) 3)
+;; (test-case (make-sum 1 'x) '(x + 1))
+;; (test-case (make-sum 'x 'y) '(x + y))
+;; (test-case (make-sum (make-sum -3 'y)
+;; (make-sum 3 'x)) '(y + x))
+;; (make-sum '(y + -3) '(x + 3))
+;; (make-sum 'y -3 'x 3)
+;; (test-case (make-sum -3 'y 3 'x) '(y + x))
+;; (test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d))
+;; (test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum 'z (make-sum 1 'x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials
+;; (test-case (make-sum 4 '(2 * x * y)) '(2 * x * y + 4))
+;; (test-case (make-sum '(3 * z) '(2 * x * y)) '(3 * z + 2 * x * y))
+;; (test-case (make-sum '(a * b) '(c * (d + 1) * e) '((f + 2) * (g + 3) * h)) '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
+
+;; given a list of items to multiply, check to see if any of the items are products.
+;; If they are, return a new list with the multiplier and multiplicands as separate expressions
+(define (break-products exps)
+ (if (null? exps)
+ '()
+ (let ((x (car exps)))
+ (if (product? x)
+ (cons (multiplier x)
+ (break-products (cons (multiplicand x) (cdr exps))))
+ (cons x (break-products (cdr exps)))))))
+
+;; (newline)
+;; (display "break-products")
+;; (newline)
+;; (test-case (break-products '((5 * x) x 3)) '(5 x x 3))
+;; (test-case (break-products '((x * (5 * x)) x 3)) '(x 5 x x 3))
+;; (test-case (break-products '((5 * a * b + x + y) (x * y + 5) (2 * a * b) (x * y))) '((5 * a * b + x + y) (x * y + 5) 2 a b x y))
+
+;; interpolate '* signs between expressions
+(define (add-mult-signs exps)
+ (if (null? exps)
+ '() ;; this should never execute
+ (let ((x (car exps))
+ (remnant (cdr exps)))
+ (cond ((null? remnant)
+ (if (or (number? x)
+ (variable? x)
+ (sum? x))
+ (list x)
+ x)) ;; when x is a one-element list like '((x ** y))
+ ((or (number? x)
+ (variable? x)
+ (sum? x))
+ (cons x (cons '* (add-mult-signs remnant))))
+ ((product? x)
+ (error "unexpected product"))
+ (else (error "expression type not yet implemented"))))))
+;; (newline)
+;; (display "add-mult-signs")
+;; (newline)
+;; (test-case (add-mult-signs '()) '())
+;; (test-case (add-mult-signs '(1)) '(1))
+;; (test-case (add-mult-signs '(4 x y z)) '(4 * x * y * z))
+;; (test-case (add-mult-signs '((x * y))) '(x * y))
+;; (test-case (add-mult-signs '(5 (x + y))) '(5 * (x + y)))
+;; (test-case (add-mult-signs '((x + y) (x + 1) ((2 * x + 1) + 5 * x))) '((x + y) * (x + 1) * ((2 * x + 1) + 5 * x)))
+;; (test-case (add-mult-signs '((x * y + 2) (y + 5) a b (a * b + 2) c (d + 1) (e + 4)))
+;; '((x * y + 2) * (y + 5) * a * b * (a * b + 2) * c * (d + 1) * (e + 4)))
+
+;; If the exp is a:
+;; variable or number, we just multiply without adding any extra parentheses
+;; sum, then we leave the parentheses intact and multiply, treating the sum as a single term
+;; product, then we must remove the parentheses around the product (optionally leaving the multiplier's and potentially multiple multiplicands' parentheses intact). We must deal with the multiplier and potentially multiple multiplicands as separate terms.
+;; (not implemented) a complex expression, we remove the parentheses around the expression and treat it as a single term
+
+(define (make-product . exps)
+ (let* ((terms (break-products exps))
+ (nums (filter number? terms))
+ (non-nums (filter (lambda (exp) (not (number? exp))) terms))
+ (product-of-nums (fold-right * 1 nums)))
+ (cond ((null? non-nums) product-of-nums)
+ ((= product-of-nums 0) 0)
+ ((and (= product-of-nums 1)
+ (null? (cdr non-nums))) (car non-nums))
+ ((= product-of-nums 1) (add-mult-signs non-nums))
+ (else (add-mult-signs (cons product-of-nums non-nums))))))
+
+;; (test-case (make-product 5 '(5 * x)) '(25 * x))
+;; (test-case (make-product 5 'x) '(5 * x))
+;; (test-case (make-product 5 2) 10)
+;; (test-case (make-product 0 'x) 0)
+;; (test-case (make-product 5 2 'x) '(10 * x))
+;; (test-case (make-product 5 1/5 'x 'y) '(x * y))
+;; (test-case (make-product (make-product 'x 5) (make-product 'x 3 (make-product 1/15 'y 'z)) 'x) '(x * x * y * z * x))
+;; (test-case (make-product '(x + 3) 'y) '((x + 3) * y))
+;; (test-case (make-product (make-sum 5 'x)
+;; (make-product 'x 'y)
+;; (make-sum 'z 2))
+;; '((x + 5) * x * y * (z + 2)))
+;; (test-case (make-product
+;; (make-sum (make-product 5 'x)
+;; (make-product 3 'y))
+;; (make-sum (make-product 2 'y)
+;; (make-product 2 3))
+;; (make-sum (make-sum 'x 4) (make-product 3 'y)))
+;; '((5 * x + 3 * y) * (2 * y + 6) * (x + 3 * y + 4)))
+;; (test-case (make-sum (make-product 'a 'b)
+;; (make-product 'c (make-sum 'd 1) 'e)
+;; (make-product (make-sum 'f 2) (make-sum 'g 3) 'h))
+;; '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
+;; (test-case (make-product (make-sum 5 'x)
+;; (make-product 'x 'y)
+;; (make-sum 'z 2))
+;; '((x + 5) * x * y * (z + 2)))
+
+
+
+
+(test-case (deriv '(x * y * (x + 3)) 'x) '(x * y + y * (x + 3)))
blob - /dev/null
blob + 7ecac9b8e9145b03f382baf87565ca8a9aa2a84d (mode 644)
--- /dev/null
+++ ex2-58c.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (variable? x) (symbol? x))
+(define (same-variable? v1 v2)
+ (and (variable? v1) (variable? v2) (eq? v1 v2)))
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp) (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp) (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (error "unknown expression type -- DERIV" exp)))
+
+;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works?
+
+(define (sum? x)
+ (and (not (number? x))
+ (not (variable? x))
+ (not (null? (cdr x)))
+ (or (eq? (cadr x) '+)
+ (sum? (cddr x)))))
+;; sum?
+;; (newline)
+;; (display "sum??")
+;; (newline)
+;; (test-case (sum? '(5 + x)) #t)
+;; (test-case (sum? '(5 * x + 3)) #t)
+;; (test-case (sum? '(8 * x)) #f)
+;; (test-case (sum? 5) #f)
+;; (test-case (sum? '(5 * x + 8 * y)) #t)
+;; (test-case (sum? '(y * ((5 * x) + 3) + 2)) #t)
+
+;; an expression is a product if it is not a sum and contains a * sign somewhere in the top 'level' of a list
+(define (product? x)
+ (and (not (number? x))
+ (not (variable? x))
+ (not (sum? x))
+ (not (null? (cdr x)))
+ (or (eq? (cadr x) '*)
+ (product? (cddr x)))))
+;; (newline)
+;; (display "product?")
+;; (newline)
+;; (test-case (product? '(2 * x * y + 4)) #f)
+;; (test-case (product? '(x * y * z)) #t)
+;; (test-case (product? '((x + 1) * y)) #t)
+;; (test-case (product? '((x + (3 * z) * y) + (5 * z * (3 * y + 5)))) #f)
+;; (test-case (product? '((x + 3 * z * y) * y + 5)) #f)
+
+;; If the first operation is +, we return the first element in the list
+;; Otherwise, we join the first two elements to the addend of the rest
+;; of the list.
+(define (addend s)
+ (if (eq? '+ (cadr s))
+ (car s)
+;; we do not test if (cadddr s) is a number or variable because it might
+;; be a single nested list
+ (if (eq? (cadddr s) '+)
+ (list (car s) (cadr s) (addend (cddr s)))
+ (cons (car s)
+ (cons (cadr s)
+ (addend (cddr s)))))))
+;; (newline)
+;; (display "addend")
+;; (newline)
+;; (test-case (addend '(a + b + c)) 'a)
+;; (test-case (addend '(3 * x + 4 * y)) '(3 * x))
+;; (test-case (addend '(x * y * (z + 1) + (2 * 2))) '(x * y * (z + 1)))
+;; (test-case (addend '(2 * x * y + 4)) '(2 * x * y))
+;; (test-case (addend '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
+;; '((y + 1) * (y + 2)))
+;; (test-case (addend '((y + 1) * (y + 2) * (y + 3) + 2 * ((3 * y) * 2) + 1))
+;; '((y + 1) * (y + 2) * (y + 3)))
+
+;; If the first operation is +, we return the either the third element of the list if it is a single expression, or the rest of the list if there are more elements.
+(define (augend s)
+ (if (eq? '+ (cadr s))
+ (if (null? (cdddr s))
+ (caddr s)
+ (cddr s))
+ (augend (cddr s))))
+;; (newline)
+;; (display "augend")
+;; (newline)
+;; (test-case (augend '(x + 6)) '6)
+;; (test-case (augend '(x + y + 6)) '(y + 6))
+;; (test-case (augend '(x + y * x)) '(y * x))
+;; (test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5))
+;; (test-case (augend '(5 * x + 3 * y + 3))
+;; '(3 * y + 3))
+;; (test-case (augend '(5 * x + (y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
+;; '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
+
+(define (multiplier p)
+ (car p))
+;; (newline)
+;; (display "multiplier")
+;; (newline)
+;; (test-case (multiplier '(5 * x)) 5)
+;; (test-case (multiplier '(x * (x + 2))) 'x)
+;; (test-case (multiplier '((x + 1) * (x + 2) * (x + 3))) '(x + 1))
+;; (test-case (multiplier '((5 * x + 2) * 3)) '(5 * x + 2))
+;; (test-case (multiplier '((((x + 1) * (x + 2)) + 5) * (x + 3))) '(((x + 1) * (x + 2)) + 5))
+;; (test-case (multiplier '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(y * (x + 5 * (y + 2)) + 4))
+;; (test-case (multiplier '((x + y + z) * (x + y))) '(x + y + z))
+
+(define (multiplicand p)
+ (if (null? (cdddr p))
+ (caddr p)
+ (cddr p)))
+;; (newline)
+;; (display "multiplicand")
+;; (newline)
+;; (test-case (multiplicand '(5 * x)) 'x)
+;; (test-case (multiplicand '(x * (x + 2))) '(x + 2))
+;; (test-case (multiplicand '((x + 1) * (x + 2) * (x + 3))) '((x + 2) * (x + 3)))
+;; (test-case (multiplicand '((5 * x + 2) * y)) 'y)
+;; (test-case (multiplicand '((((x + 1) * (x + 2)) + 5) * (x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) '((x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1)))
+;; (test-case (multiplicand '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(x * z))
+;; (test-case (multiplicand '((x + y + z) * (x + y))) '(x + y))
+
+;; given a list of items to sum, check to see if any of the items are sums.
+;; If they are, return a new list with the addend and augends as separate expressions
+(define (break-sums exps)
+ (if (null? exps)
+ '()
+ (let ((x (car exps)))
+ (if (sum? x)
+ (cons (addend x)
+ (break-sums (cons (augend x) (cdr exps))))
+ (cons x (break-sums (cdr exps)))))))
+
+;; (newline)
+;; (display "break-sums")
+;; (newline)
+;; (test-case (break-sums '((x + 5) x 3)) '(x 5 x 3))
+;; (test-case (break-sums '((x + (x + 5)) x 3)) '(x x 5 x 3))
+;; (test-case (break-sums '((x + 5 + 2 * x * y) (x * y + 5) (a + 2 + 3 * x) (x + a * b * c + 7))) '(x 5 (2 * x * y) (x * y) 5 a 2 (3 * x) x (a * b * c) 7))
+
+;; interpolate '+ signs between expressions
+(define (add-plus-signs exps)
+ (if (null? exps)
+ '() ;; this should never execute
+ (let ((x (car exps))
+ (remnant (cdr exps)))
+ (cond ((null? remnant)
+ (if (or (number? x)
+ (variable? x))
+ (list x)
+ x)) ;; when x is a one-element list like '((x * y))
+ ((or (number? x)
+ (variable? x))
+ (cons x (cons '+ (add-plus-signs remnant))))
+ ((sum? x)
+ (error "unexpected sum"))
+ ((product? x)
+ (cons (multiplier x)
+ (cons '*
+ (add-plus-signs (cons (multiplicand x) remnant)))))
+ (else (error "expression type not yet implemented"))))))
+;; (newline)
+;; (display "add-plus-signs")
+;; (newline)
+;; (test-case (add-plus-signs '()) '())
+;; (test-case (add-plus-signs '(1)) '(1))
+;; (test-case (add-plus-signs '(x y z 4)) '(x + y + z + 4))
+;; (test-case (add-plus-signs '((x * y))) '(x * y))
+;; (test-case (add-plus-signs '((x * y) 5)) '(x * y + 5))
+;; (test-case (add-plus-signs '(((x * y) * (x + 1)) (5 * (x + 1)))) '((x * y) * (x + 1) + 5 * (x + 1)))
+;; (test-case (add-plus-signs '(((x * y + 2) * (y + 5)) a b (((a * b + 2) * c * (d + 1)) * (e + 4))))
+;; '((x * y + 2) * (y + 5) + a + b + ((a * b + 2) * c * (d + 1)) * (e + 4)))
+
+;; If the term is:
+;; a number or a variable: we deal with it is without adding or removing any parentheses
+;; a product: we must remove the parentheses around the product but not tamper with parentheses within the multiplier or multiplicand. We must deal with the product as a single term.
+;; a sum: we must remove the parentheses around the sum (but we can optionally leave the addend's and potentially multiple augends' existing parentheses intact). We must then deal with the addend and potentially multiple augends as separate terms
+(define (make-sum . exps)
+ (let* ((terms (break-sums exps))
+ (nums (filter number? terms))
+ (non-nums (filter (lambda (exp) (not (number? exp))) terms))
+ (sum-of-nums (fold-right + 0 nums)))
+ (cond ((null? non-nums) sum-of-nums)
+ ((and (= sum-of-nums 0)
+ (null? (cdr non-nums))) (car non-nums))
+ ((= sum-of-nums 0) (add-plus-signs non-nums))
+ (else (add-plus-signs (append non-nums (list sum-of-nums)))))))
+;; (newline)
+;; (display "make-sum")
+;; (newline)
+;; (test-case (make-sum 0 'x) 'x)
+;; (test-case (make-sum 1 2) 3)
+;; (test-case (make-sum 1 'x) '(x + 1))
+;; (test-case (make-sum 'x 'y) '(x + y))
+;; (test-case (make-sum (make-sum -3 'y)
+;; (make-sum 3 'x)) '(y + x))
+;; (make-sum '(y + -3) '(x + 3))
+;; (make-sum 'y -3 'x 3)
+;; (test-case (make-sum -3 'y 3 'x) '(y + x))
+;; (test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d))
+;; (test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum 'z (make-sum 1 'x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials
+;; (test-case (make-sum 4 '(2 * x * y)) '(2 * x * y + 4))
+;; (test-case (make-sum '(3 * z) '(2 * x * y)) '(3 * z + 2 * x * y))
+;; (test-case (make-sum '(a * b) '(c * (d + 1) * e) '((f + 2) * (g + 3) * h)) '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
+
+;; given a list of items to multiply, check to see if any of the items are products.
+;; If they are, return a new list with the multiplier and multiplicands as separate expressions
+(define (break-products exps)
+ (if (null? exps)
+ '()
+ (let ((x (car exps)))
+ (if (product? x)
+ (cons (multiplier x)
+ (break-products (cons (multiplicand x) (cdr exps))))
+ (cons x (break-products (cdr exps)))))))
+
+;; (newline)
+;; (display "break-products")
+;; (newline)
+;; (test-case (break-products '((5 * x) x 3)) '(5 x x 3))
+;; (test-case (break-products '((x * (5 * x)) x 3)) '(x 5 x x 3))
+;; (test-case (break-products '((5 * a * b + x + y) (x * y + 5) (2 * a * b) (x * y))) '((5 * a * b + x + y) (x * y + 5) 2 a b x y))
+
+;; interpolate '* signs between expressions
+(define (add-mult-signs exps)
+ (if (null? exps)
+ '() ;; this should never execute
+ (let ((x (car exps))
+ (remnant (cdr exps)))
+ (cond ((null? remnant)
+ (if (or (number? x)
+ (variable? x)
+ (sum? x))
+ (list x)
+ x)) ;; when x is a one-element list like '((x ** y))
+ ((or (number? x)
+ (variable? x)
+ (sum? x))
+ (cons x (cons '* (add-mult-signs remnant))))
+ ((product? x)
+ (error "unexpected product"))
+ (else (error "expression type not yet implemented"))))))
+;; (newline)
+;; (display "add-mult-signs")
+;; (newline)
+;; (test-case (add-mult-signs '()) '())
+;; (test-case (add-mult-signs '(1)) '(1))
+;; (test-case (add-mult-signs '(4 x y z)) '(4 * x * y * z))
+;; (test-case (add-mult-signs '((x * y))) '(x * y))
+;; (test-case (add-mult-signs '(5 (x + y))) '(5 * (x + y)))
+;; (test-case (add-mult-signs '((x + y) (x + 1) ((2 * x + 1) + 5 * x))) '((x + y) * (x + 1) * ((2 * x + 1) + 5 * x)))
+;; (test-case (add-mult-signs '((x * y + 2) (y + 5) a b (a * b + 2) c (d + 1) (e + 4)))
+;; '((x * y + 2) * (y + 5) * a * b * (a * b + 2) * c * (d + 1) * (e + 4)))
+
+;; If the exp is a:
+;; variable or number, we just multiply without adding any extra parentheses
+;; sum, then we leave the parentheses intact and multiply, treating the sum as a single term
+;; product, then we must remove the parentheses around the product (optionally leaving the multiplier's and potentially multiple multiplicands' parentheses intact). We must deal with the multiplier and potentially multiple multiplicands as separate terms.
+;; (not implemented) a complex expression, we remove the parentheses around the expression and treat it as a single term
+
+(define (make-product . exps)
+ (let* ((terms (break-products exps))
+ (nums (filter number? terms))
+ (non-nums (filter (lambda (exp) (not (number? exp))) terms))
+ (product-of-nums (fold-right * 1 nums)))
+ (cond ((null? non-nums) product-of-nums)
+ ((= product-of-nums 0) 0)
+ ((and (= product-of-nums 1)
+ (null? (cdr non-nums))) (car non-nums))
+ ((= product-of-nums 1) (add-mult-signs non-nums))
+ (else (add-mult-signs (cons product-of-nums non-nums))))))
+
+;; (test-case (make-product 5 '(5 * x)) '(25 * x))
+;; (test-case (make-product 5 'x) '(5 * x))
+;; (test-case (make-product 5 2) 10)
+;; (test-case (make-product 0 'x) 0)
+;; (test-case (make-product 5 2 'x) '(10 * x))
+;; (test-case (make-product 5 1/5 'x 'y) '(x * y))
+;; (test-case (make-product (make-product 'x 5) (make-product 'x 3 (make-product 1/15 'y 'z)) 'x) '(x * x * y * z * x))
+;; (test-case (make-product '(x + 3) 'y) '((x + 3) * y))
+;; (test-case (make-product (make-sum 5 'x)
+;; (make-product 'x 'y)
+;; (make-sum 'z 2))
+;; '((x + 5) * x * y * (z + 2)))
+;; (test-case (make-product
+;; (make-sum (make-product 5 'x)
+;; (make-product 3 'y))
+;; (make-sum (make-product 2 'y)
+;; (make-product 2 3))
+;; (make-sum (make-sum 'x 4) (make-product 3 'y)))
+;; '((5 * x + 3 * y) * (2 * y + 6) * (x + 3 * y + 4)))
+(test-case (make-sum (make-product 'a 'b)
+ (make-product 'c (make-sum 'd 1) 'e)
+ (make-product (make-sum 'f 2) (make-sum 'g 3) 'h))
+ '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
+(test-case (make-product (make-sum 5 'x)
+ (make-product 'x 'y)
+ (make-sum 'z 2))
+ '((x + 5) * x * y * (z + 2)))
+
+
+
+
+(test-case (deriv '(x * y * (x + 3)) 'x) '(x * y + y * (x + 3)))
blob - /dev/null
blob + 3da4a716fdb208f1a1d1cbb3d82f844812ad86dc (mode 644)
--- /dev/null
+++ ex2-59-sol.scm
+(define (union-set set1 set2)
+ (cond ((null? set1) set2)
+ ((null? set2) set1)
+ ((element-of-set? (car set1) set2) (union-set (cdr set1) set2))
+ (else (cons (car set1) (union-set (cdr set1) set2)))))
blob - /dev/null
blob + fa2a1f3391289f0bfa5a8951686918d1f693a1dc (mode 644)
--- /dev/null
+++ ex2-59.lisp
+(defun union-set (set1 set2)
+ (append
+ set1
+ (remove-if
+ (lambda (x)
+ (element-of-set? x set1))
+ set2)))
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 354c6572d6c2d6c9c2fd14e017f924dd7f8db5a2 (mode 644)
--- /dev/null
+++ ex2-59.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+
+(define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((equal? x (car set)) true)
+ (else (element-of-set? x (cdr set)))))
+(define (adjoin-set x set)
+ (if (element-of-set? x set)
+ set
+ (cons x set)))
+(define (intersection-set set1 set2)
+ (cond ((or (null? set1) (null? set2)) '())
+ ((element-of-set? (car set1) set2)
+ (cons (car set1)
+ (intersection-set (cdr set1) set2)))
+ (else (intersection-set (cdr set1) set2))))
+(define (union-set set1 set2)
+ (cond ((null? set1) set2)
+ ((null? set2) set1)
+ ((element-of-set? (car set1) set2) (union-set (cdr set1) set2))
+ (else (cons (car set1) (union-set (cdr set1) set2)))))
+
+(test-case (union-set '(1 2 3 4 5) '(1 3 4)) '(2 5 1 3 4))
+
+
blob - /dev/null
blob + 9df7d9eb5dfa240ab3252de61e5348c5631f8c09 (mode 644)
--- /dev/null
+++ ex2-59.scm~
+(element-of-set? x (adjoin-set x S))
+(element-of-set? x (union-set S T))
+(or (element-of-set? x S) (element-of-set? x T))
+(element-of-set? x '())
+(define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((equal? x (car set)) true)
+ (else (element-of-set? x (cdr set)))))
+(define (adjoin-set x set)
+ (if (element-of-set? x set)
+ set
+ (cons x set)))
+(define (intersection-set set1 set2)
+ (cond ((or (null? set1) (null? set2)) '())
+ ((element-of-set? (car set1) set2)
+ (cons (car set1)
+ (intersection-set (cdr set1) set2)))
+ (else (intersection-set (cdr set1) set2))))
+
+(define (union-set
blob - /dev/null
blob + b36ea77e3959cc80f78cfcc00abb71a42cda520b (mode 644)
--- /dev/null
+++ ex2-6.lisp
+(defvar zero
+ (lambda (f)
+ (lambda (x) x)))
+(defun add-1 (n)
+ (lambda (f)
+ (lambda (x)
+ (funcall f (funcall (funcall n f) x)))))
+(defvar one
+ (lambda (f)
+ (lambda (x) (funcall f x))))
+(defvar two
+ (lambda (f)
+ (lambda (x) (funcall f (funcall f x)))))
+(defun add (a b)
+ (lambda (f)
+ (lambda (x) (funcall (funcall a f) (funcall (funcall b f) x)))))
blob - /dev/null
blob + 935382723ab73954eace1960c85e94f2eb259e14 (mode 644)
--- /dev/null
+++ ex2-6.lisp~
+(defvar zero
+ (lambda (f)
+ (lambda (x) x)))
blob - /dev/null
blob + b8848df39fef6746cd92053597d5352111886380 (mode 644)
--- /dev/null
+++ ex2-6.scm
+;; Exercise 2.6. In case representing pairs as procedures wasn't mind-boggling enough, consider that, in a language that can manipulate procedures, we can get by without numbers (at least insofar as nonnegative integers are concerned) by implementing 0 and the operation of adding 1 as
+
+(define zero (lambda (f) (lambda (x) x)))
+
+(define (add-1 n)
+ (lambda (f) (lambda (x) (f ((n f) x)))))
+
+;; This representation is known as Church numerals, after its inventor, Alonzo Church, the logician who invented the calculus.
+
+;; Define one and two directly (not in terms of zero and add-1). (Hint: Use substitution to evaluate (add-1 zero)). Give a direct definition of the addition procedure + (not in terms of repeated application of add-1).
+
+(define one (add-1 zero))
+
+(lambda (f) (lambda (x) (f (((lambda (f) (lambda (x) x)) f) x))))
+;;(lambda (f) (lambda (x) (f ((n f) x))))
+(lambda (f) (lambda (x) (f (((lambda (f) f)) x))))
+(lambda (f) (lambda (x) (f ((lambda (f) f) x))))
+(lambda (f) (lambda (x) (f x)))
+(lambda (f) (lambda (x) (f x)))
+
+(define one (lambda (f) (lambda (x) (f x))))
+(define two (add-1 one))
+
+(lambda (f) (lambda (x) (f (((lambda (f) (lambda (x) (f x))) f) x))))
+(lambda (f) (lambda (x) (f ((lambda (x) (f x)) x))))
+(lambda (f) (lambda (x) (f (f x))))
+
+(define two (lambda (f) (lambda (x) (f (f x)))))
+
+;; Give a direct definition of the addition procedure + (not in terms of repeated application of add-1).
+
+(define (+ a b)
+ (lambda (f) (lambda (x) ((a f) ((b f) x)))))
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + f86fe2479d75b584f06a5f6c799a35b654af4de4 (mode 644)
--- /dev/null
+++ ex2-60.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+
+(define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((equal? x (car set)) true)
+ (else (element-of-set? x (cdr set)))))
+(define (adjoin-set x set)
+ (if (element-of-set? x set)
+ set
+ (cons x set)))
+(define (intersection-set set1 set2)
+ (cond ((or (null? set1) (null? set2)) '())
+ ((element-of-set? (car set1) set2)
+ (cons (car set1)
+ (intersection-set (cdr set1) set2)))
+ (else (intersection-set (cdr set1) set2))))
+(define (union-set set1 set2)
+ (cond ((null? set1) set2)
+ ((null? set2) set1)
+ ((element-of-set? (car set1) set2) (union-set (cdr set1) set2))
+ (else (cons (car set1) (union-set (cdr set1) set2)))))
+
+(test-case (union-set '(1 2 3 4 5) '(1 3 4)) '(2 5 1 3 4))
+
+;; Exercise 2.60. We specified that a set would be represented as a list with no duplicates. Now suppose we allow duplicates. For instance, the set {1,2,3} could be represented as the list (2 3 2 1 3 2 2). Design procedures element-of-set?, adjoin-set, union-set, and intersection-set that operate on this representation. How does the efficiency of each compare with the corresponding procedure for the non-duplicate representation? Are there applications for which you would use this representation in preference to the non-duplicate one?
+
+(define (element-of-set? x set)
+ (cond ((null? set) #f)
+ ((equal? x (car set)) #t)
+ (else (element-of-set? x (cdr set)))))
+(test-case (element-of-set? 4 '(1 3 5 2 3 5 5)) #f)
+(test-case (element-of-set? 3 '(1 3 5 2 3 5 5)) #t)
+
+(define (adjoin-set x set)
+ (cons x set))
+
+(test-case (adjoin-set 5 '()) '(5))
+(test-case (adjoin-set 5 '(1 3)) '(5 1 3))
+(test-case (adjoin-set 5 '(5 5 1 3)) '(5 5 5 1 3))
+
+(define (union-set set1 set2)
+ (append set1 set2))
+
+(test-case (union-set '(1 5 2 3 5) '(4 2 8 1 5)) '(1 5 2 3 5 4 2 8 1 5))
+
+(define (intersection-set set1 set2)
+ (cond ((null? set1) set2)
+ ((null? set2) set1)
+ ((element-of-set? (car set1) set2)
+ (cons (car set1) (intersection-set (cdr set1) set2)))
+ (else (intersection-set (cdr set1) set2))))
+
+(test-case (intersection-set '(1 5 2 3 5) '(4 2 8 1 5)) '(1 5 2 5 4 2 8 1 5))
+
+;; the new set has a lot of duplicated entries so that element-of-set? and
+;; intersection-set are much slower. The more duplicate entries, the slower
+;; they become. However, adjoin-set and union-set become extremely easy and
+;; fast to implement. You might use this representation when it is more
+;; important to be able to join two sets or add new elements to a set
+;; than it is to see if an element belongs to a set or is part of an
+;; intersection of two sets.
blob - /dev/null
blob + 354c6572d6c2d6c9c2fd14e017f924dd7f8db5a2 (mode 644)
--- /dev/null
+++ ex2-60.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+
+(define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((equal? x (car set)) true)
+ (else (element-of-set? x (cdr set)))))
+(define (adjoin-set x set)
+ (if (element-of-set? x set)
+ set
+ (cons x set)))
+(define (intersection-set set1 set2)
+ (cond ((or (null? set1) (null? set2)) '())
+ ((element-of-set? (car set1) set2)
+ (cons (car set1)
+ (intersection-set (cdr set1) set2)))
+ (else (intersection-set (cdr set1) set2))))
+(define (union-set set1 set2)
+ (cond ((null? set1) set2)
+ ((null? set2) set1)
+ ((element-of-set? (car set1) set2) (union-set (cdr set1) set2))
+ (else (cons (car set1) (union-set (cdr set1) set2)))))
+
+(test-case (union-set '(1 2 3 4 5) '(1 3 4)) '(2 5 1 3 4))
+
+
blob - /dev/null
blob + a0f25894ba5e4acd2dbecfbb6485293bbdaeeeb9 (mode 644)
--- /dev/null
+++ ex2-61.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((= x (car set)) true)
+ ((< x (car set)) false)
+ (else (element-of-set? x (cdr set)))))
+(define (intersection-set set1 set2)
+ (if (or (null? set1) (null? set2))
+ '()
+ (let ((x1 (car set1)) (x2 (car set2)))
+ (cond ((= x1 x2) (cons x1
+ (intersection-set (cdr set1)
+ (cdr set2))))
+ ((< x1 x2) (intersection-set (cdr set1)
+ set2))
+ ((> x1 x2) (intersection-set set1
+ (cdr set2)))))))
+
+;; Exercise 2.61. Give an implementation of adjoin-set using the ordered representation. By analogy with element-of-set? show how to take advantage of the ordering to produce a procedure that requires on the average about half as many steps as with the unordered representation.
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((= x (car set)) set)
+ ((< x (car set)) (cons x set))
+ (else (cons (car set) (adjoin-set x (cdr set))))))
+
+(test-case (adjoin-set 5 '()) '(5))
+(test-case (adjoin-set 5 '(1 2 3 4 5)) '(1 2 3 4 5))
+(test-case (adjoin-set 5 '(1 2 3 4)) '(1 2 3 4 5))
+(test-case (adjoin-set 5 '(6 7 8 9)) '(5 6 7 8 9))
+(test-case (adjoin-set 5 '(1 2 3 4 6 7 8 9)) '(1 2 3 4 5 6 7 8 9))
+
+ Exercise 2.62. Give a (n) implementation of union-set for sets represented as ordered lists.
blob - /dev/null
blob + f86fe2479d75b584f06a5f6c799a35b654af4de4 (mode 644)
--- /dev/null
+++ ex2-61.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+
+(define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((equal? x (car set)) true)
+ (else (element-of-set? x (cdr set)))))
+(define (adjoin-set x set)
+ (if (element-of-set? x set)
+ set
+ (cons x set)))
+(define (intersection-set set1 set2)
+ (cond ((or (null? set1) (null? set2)) '())
+ ((element-of-set? (car set1) set2)
+ (cons (car set1)
+ (intersection-set (cdr set1) set2)))
+ (else (intersection-set (cdr set1) set2))))
+(define (union-set set1 set2)
+ (cond ((null? set1) set2)
+ ((null? set2) set1)
+ ((element-of-set? (car set1) set2) (union-set (cdr set1) set2))
+ (else (cons (car set1) (union-set (cdr set1) set2)))))
+
+(test-case (union-set '(1 2 3 4 5) '(1 3 4)) '(2 5 1 3 4))
+
+;; Exercise 2.60. We specified that a set would be represented as a list with no duplicates. Now suppose we allow duplicates. For instance, the set {1,2,3} could be represented as the list (2 3 2 1 3 2 2). Design procedures element-of-set?, adjoin-set, union-set, and intersection-set that operate on this representation. How does the efficiency of each compare with the corresponding procedure for the non-duplicate representation? Are there applications for which you would use this representation in preference to the non-duplicate one?
+
+(define (element-of-set? x set)
+ (cond ((null? set) #f)
+ ((equal? x (car set)) #t)
+ (else (element-of-set? x (cdr set)))))
+(test-case (element-of-set? 4 '(1 3 5 2 3 5 5)) #f)
+(test-case (element-of-set? 3 '(1 3 5 2 3 5 5)) #t)
+
+(define (adjoin-set x set)
+ (cons x set))
+
+(test-case (adjoin-set 5 '()) '(5))
+(test-case (adjoin-set 5 '(1 3)) '(5 1 3))
+(test-case (adjoin-set 5 '(5 5 1 3)) '(5 5 5 1 3))
+
+(define (union-set set1 set2)
+ (append set1 set2))
+
+(test-case (union-set '(1 5 2 3 5) '(4 2 8 1 5)) '(1 5 2 3 5 4 2 8 1 5))
+
+(define (intersection-set set1 set2)
+ (cond ((null? set1) set2)
+ ((null? set2) set1)
+ ((element-of-set? (car set1) set2)
+ (cons (car set1) (intersection-set (cdr set1) set2)))
+ (else (intersection-set (cdr set1) set2))))
+
+(test-case (intersection-set '(1 5 2 3 5) '(4 2 8 1 5)) '(1 5 2 5 4 2 8 1 5))
+
+;; the new set has a lot of duplicated entries so that element-of-set? and
+;; intersection-set are much slower. The more duplicate entries, the slower
+;; they become. However, adjoin-set and union-set become extremely easy and
+;; fast to implement. You might use this representation when it is more
+;; important to be able to join two sets or add new elements to a set
+;; than it is to see if an element belongs to a set or is part of an
+;; intersection of two sets.
blob - /dev/null
blob + 3752e1bcc5f60a0b5a9ab9c3b0b0e0e74e436465 (mode 644)
--- /dev/null
+++ ex2-62-sol.scm
+(define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((= x (car set)) true)
+ ((< x (car set)) false)
+ (else (element-of-set? x (cdr set)))))
+(define (intersection-set set1 set2)
+ (if (or (null? set1) (null? set2))
+ '()
+ (let ((x1 (car set1)) (x2 (car set2)))
+ (cond ((= x1 x2) (cons x1 (intersection-set (cdr set1) (cdr set2))))
+ ((< x1 x2) (intersection-set (cdr set1) set2))
+ ((< x2 x1) (intersection-set set1 (cdr set2)))))))
+(define (adjoin-set x set)
+ (cond ((null? set) (cons x '()))
+ ((= x (car set)) set)
+ ((< x (car set)) (cons x set))
+ ((> x (car set)) (cons (car set)
+ (adjoin-set x (cdr set))))))
+(define (union-set set1 set2)
+ (cond ((null? set1) set2)
+ ((null? set2) set1)
+ ((= (car set1) (car set2))
+ (cons (car set1) (union-set (cdr set1) (cdr set2))))
+ ((< (car set1) (car set2))
+ (cons (car set1) (union-set (cdr set1) set2)))
+ (else (cons (car set2) (union-set set1 (cdr set2))))))
blob - /dev/null
blob + 9a92014f76eabc433096459e37fcaafbb93b526f (mode 644)
--- /dev/null
+++ ex2-62-sol.scm~
+(define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((= x (car set)) true)
+ ((< x (car set)) false)
+ (else (element-of-set? x (cdr set)))))
blob - /dev/null
blob + 758b3e0e59c519d62b8f90d72dd224cc309dcdc9 (mode 644)
--- /dev/null
+++ ex2-62.lisp
+(defun union-set (set1 set2)
+ (append
+ set1
+ (remove-if
+ (lambda (x)
+ (element-of-set? x set1))
+ set22)))
+(defun element-of-multiset? (x set)
+ (member x set :test #'equal))
+(defun intersection-multiset (set1 set2)
+ (cond ((or (null set1) (null set2)) '())
+ ((element-of-multiset? (car set1) set2)
+ (cons (car set1)
+ (intersection-multiset (cdr set1) set2)))
+ (t (intersection-multiset (cdr set1) set2))))
+(defun adjoin-multiset (x set)
+ (cons x set))
+(defun union-multiset (set1 set2)
+ (append set1 set2))
+
+(defun adjoin-set (x set)
+ (cond ((null set) (cons x '()))
+ ((< x (car set)) (cons x set))
+ ((= x (car set)) set)
+ (t (cons (car set)
+ (adjoin-set x (cdr set))))))
+(defun union-set (set1 set2)
+ (let ((x1 (car set1)) (x2 (car set2)))
+ (cond ((null x1) set2)
+ ((null x2) set1)
+ ((= x1 x2)
+ (cons x1 (union-set (cdr set1) (cdr set2))))
+ ((< x1 x2)
+ (cons x1 (union-set (cdr set1) set2)))
+ (t
+ (cons x2 (union-set set1 (cdr set2)))))))
blob - /dev/null
blob + 96b0585b719670fc241a0ae8f99cf092fa411694 (mode 644)
--- /dev/null
+++ ex2-62.lisp~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((= x (car set)) true)
+ ((< x (car set)) false)
+ (else (element-of-set? x (cdr set)))))
+(define (intersection-set set1 set2)
+ (if (or (null? set1) (null? set2))
+ '()
+ (let ((x1 (car set1)) (x2 (car set2)))
+ (cond ((= x1 x2) (cons x1
+ (intersection-set (cdr set1)
+ (cdr set2))))
+ ((< x1 x2) (intersection-set (cdr set1)
+ set2))
+ ((> x1 x2) (intersection-set set1
+ (cdr set2)))))))
+
+;; Exercise 2.61. Give an implementation of adjoin-set using the ordered representation. By analogy with element-of-set? show how to take advantage of the ordering to produce a procedure that requires on the average about half as many steps as with the unordered representation.
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((= x (car set)) set)
+ ((< x (car set)) (cons x set))
+ (else (cons (car set) (adjoin-set x (cdr set))))))
+
+(test-case (adjoin-set 5 '()) '(5))
+(test-case (adjoin-set 5 '(1 2 3 4 5)) '(1 2 3 4 5))
+(test-case (adjoin-set 5 '(1 2 3 4)) '(1 2 3 4 5))
+(test-case (adjoin-set 5 '(6 7 8 9)) '(5 6 7 8 9))
+(test-case (adjoin-set 5 '(1 2 3 4 6 7 8 9)) '(1 2 3 4 5 6 7 8 9))
+
+;; Exercise 2.62. Give a (n) implementation of union-set for sets represented as ordered lists.
+
+(define (union-set set1 set2)
+ (cond ((null? set1) set2)
+ ((null? set2) set1)
+ (else
+ (let ((x1 (car set1))
+ (x2 (car set2)))
+ (cond ((= x1 x2) (cons x1 (union-set (cdr set1) (cdr set2))))
+ ((< x1 x2) (cons x1 (union-set (cdr set1) set2)))
+ ((> x1 x2) (cons x2 (union-set set1 (cdr set2)))))))))
+
+(test-case (union-set '(1 2 3 4 5) '(2 3 4)) '(1 2 3 4 5))
+(test-case (union-set '(1 2 3) '()) '(1 2 3))
+(test-case (union-set '() '(1 2 3)) '(1 2 3))
+(test-case (union-set '(1 2 3 4 5) '(6 7 8 9 10)) '(1 2 3 4 5 6 7 8 9 10))
+(test-case (union-set '(1 3 5 7) '(2 3 4 5)) '(1 2 3 4 5 7))
blob - /dev/null
blob + 96b0585b719670fc241a0ae8f99cf092fa411694 (mode 644)
--- /dev/null
+++ ex2-62.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((= x (car set)) true)
+ ((< x (car set)) false)
+ (else (element-of-set? x (cdr set)))))
+(define (intersection-set set1 set2)
+ (if (or (null? set1) (null? set2))
+ '()
+ (let ((x1 (car set1)) (x2 (car set2)))
+ (cond ((= x1 x2) (cons x1
+ (intersection-set (cdr set1)
+ (cdr set2))))
+ ((< x1 x2) (intersection-set (cdr set1)
+ set2))
+ ((> x1 x2) (intersection-set set1
+ (cdr set2)))))))
+
+;; Exercise 2.61. Give an implementation of adjoin-set using the ordered representation. By analogy with element-of-set? show how to take advantage of the ordering to produce a procedure that requires on the average about half as many steps as with the unordered representation.
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((= x (car set)) set)
+ ((< x (car set)) (cons x set))
+ (else (cons (car set) (adjoin-set x (cdr set))))))
+
+(test-case (adjoin-set 5 '()) '(5))
+(test-case (adjoin-set 5 '(1 2 3 4 5)) '(1 2 3 4 5))
+(test-case (adjoin-set 5 '(1 2 3 4)) '(1 2 3 4 5))
+(test-case (adjoin-set 5 '(6 7 8 9)) '(5 6 7 8 9))
+(test-case (adjoin-set 5 '(1 2 3 4 6 7 8 9)) '(1 2 3 4 5 6 7 8 9))
+
+;; Exercise 2.62. Give a (n) implementation of union-set for sets represented as ordered lists.
+
+(define (union-set set1 set2)
+ (cond ((null? set1) set2)
+ ((null? set2) set1)
+ (else
+ (let ((x1 (car set1))
+ (x2 (car set2)))
+ (cond ((= x1 x2) (cons x1 (union-set (cdr set1) (cdr set2))))
+ ((< x1 x2) (cons x1 (union-set (cdr set1) set2)))
+ ((> x1 x2) (cons x2 (union-set set1 (cdr set2)))))))))
+
+(test-case (union-set '(1 2 3 4 5) '(2 3 4)) '(1 2 3 4 5))
+(test-case (union-set '(1 2 3) '()) '(1 2 3))
+(test-case (union-set '() '(1 2 3)) '(1 2 3))
+(test-case (union-set '(1 2 3 4 5) '(6 7 8 9 10)) '(1 2 3 4 5 6 7 8 9 10))
+(test-case (union-set '(1 3 5 7) '(2 3 4 5)) '(1 2 3 4 5 7))
blob - /dev/null
blob + a0f25894ba5e4acd2dbecfbb6485293bbdaeeeb9 (mode 644)
--- /dev/null
+++ ex2-62.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((= x (car set)) true)
+ ((< x (car set)) false)
+ (else (element-of-set? x (cdr set)))))
+(define (intersection-set set1 set2)
+ (if (or (null? set1) (null? set2))
+ '()
+ (let ((x1 (car set1)) (x2 (car set2)))
+ (cond ((= x1 x2) (cons x1
+ (intersection-set (cdr set1)
+ (cdr set2))))
+ ((< x1 x2) (intersection-set (cdr set1)
+ set2))
+ ((> x1 x2) (intersection-set set1
+ (cdr set2)))))))
+
+;; Exercise 2.61. Give an implementation of adjoin-set using the ordered representation. By analogy with element-of-set? show how to take advantage of the ordering to produce a procedure that requires on the average about half as many steps as with the unordered representation.
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((= x (car set)) set)
+ ((< x (car set)) (cons x set))
+ (else (cons (car set) (adjoin-set x (cdr set))))))
+
+(test-case (adjoin-set 5 '()) '(5))
+(test-case (adjoin-set 5 '(1 2 3 4 5)) '(1 2 3 4 5))
+(test-case (adjoin-set 5 '(1 2 3 4)) '(1 2 3 4 5))
+(test-case (adjoin-set 5 '(6 7 8 9)) '(5 6 7 8 9))
+(test-case (adjoin-set 5 '(1 2 3 4 6 7 8 9)) '(1 2 3 4 5 6 7 8 9))
+
+ Exercise 2.62. Give a (n) implementation of union-set for sets represented as ordered lists.
blob - /dev/null
blob + a9f5db0d7f13c2ddd42b52258a4697109a27900a (mode 644)
--- /dev/null
+++ ex2-63-sol.scm
+(define (tree->list-1 tree)
+ (if (null? tree)
+ '()
+ (append (tree->list-1 (left-branch tree))
+ (cons (entry tree)
+ (tree->list-1 (right-branch tree))))))
+(define (tree->list-2 tree)
+ (define (copy-to-list tree result-list)
+ (if (null? tree)
+ result-list
+ (copy-to-list (left-branch tree)
+ (cons (entry tree)
+ (copy-to-list (right-branch tree)
+ result-list)))))
+ (copy-to-list tree '()))
blob - /dev/null
blob + 52ea5b0e15be8c0d2b5f024995ab567448ff3bca (mode 644)
--- /dev/null
+++ ex2-63-sol.scm~
+(define (tree->list-1 tree)
+ (if (null? tree)
+ '()
+ (append (tree->list-1 (left-branch tree))
+ (cons (entry tree)
+ (tree->list-1 (right-branch tree))))))
blob - /dev/null
blob + f6ad0a861bc86803da1bb605f2a9745093ccc34e (mode 644)
--- /dev/null
+++ ex2-63.scm
+(define (entry tree) (car tree))
+(define (left-branch tree) (cadr tree))
+(define (right-branch tree) (caddr tree))
+(define (make-tree entry left right)
+ (list entry left right))
+
+(define (element-of-set? x set)
+ (cond ((null? set) #f)
+ ((= x (entry set)) #t)
+ ((< x (entry set))
+ (element-of-set? x (left-branch set)))
+ ((> x (entry set))
+ (element-of-set? x (right-branch set)))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (make-tree x '() '()))
+ ((= x (entry set)) set)
+ ((< x (entry set))
+ (make-tree (entry set)
+ (adjoin-set x (left-branch set))
+ (right-branch set)))
+ ((> x (entry set))
+ (make-tree (entry set)
+ (left-branch set)
+ (adjoin-set x (right-branch set))))))
+(define (tree->list-1 tree)
+ (if (null? tree)
+ '()
+ (append (tree->list-1 (left-branch tree))
+ (cons (entry tree)
+ (tree->list-1 (right-branch tree))))))
+(define (tree->list-2 tree)
+ (define (copy-to-list tree result-list)
+ (if (null? tree)
+ result-list
+ (copy-to-list (left-branch tree)
+ (cons (entry tree)
+ (copy-to-list (right-branch tree)
+ result-list)))))
+ (copy-to-list tree '()))
+
+;; a. Do the two procedures produce the same result for every tree? If not, how do the results differ? What lists do the two procedures produce for the trees in figure 2.16?
+
+;; Yes, they produce the same result for every tree. They both produce '(1, 3, 5, 7, 9, 11)
+
+;; b. Do the two procedures have the same order of growth in the number of steps required to convert a balanced tree with n elements to a list? If not, which one grows more slowly?
+
+;; No, the second procedure is faster. Each procedure makes around n calls to itself (slightly more calls since there are 2 extra per tree with empty leaves). However, the first procedure uses append whereas the second one uses cons. Append has order of growth of (length list1), so I'm guessing the overall order of growth for tree->list-1 is n^2? whereas it is n? for tree->list-2.
blob - /dev/null
blob + bd27e61af567d5cd9cb80387634c5a7800a8d78f (mode 644)
--- /dev/null
+++ ex2-63.scm~
+(define (entry tree) (car tree))
+(define (left-branch tree) (cadr tree))
+(define (right-branch tree) (caddr tree))
+(define (make-tree entry left right)
+ (list entry left right))
+
+(define (element-of-set? x set)
+ (cond ((null? set) #f)
+ ((= x (entry set)) #t)
+ ((< x (entry set))
+ (element-of-set? x (left-branch set)))
+ ((> x (entry set))
+ (element-of-set? x (right-branch set)))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (make-tree x '() '()))
+ ((= x (entry set)) set)
+ ((< x (entry set))
+ (make-tree (entry set)
+ (adjoin-set x (left-branch set))
+ (right-branch set)))
+ ((> x (entry set))
+ (make-tree (entry set)
+ (left-branch set)
+ (adjoin-set x (right-branch set))))))
blob - /dev/null
blob + 8aa54fb859cd12ddf62b7bdec24091a65d49a369 (mode 644)
--- /dev/null
+++ ex2-64-sol.scm
+(define (list->tree elements)
+ (car (partial-tree elements (length elements))))
+
+(define (partial-tree elts n)
+ (if (= n 0)
+ (cons '() elts)
+ (let ((left-size (quotient (- n 1) 2)))
+ (let ((left-result (partial-tree elts left-size)))
+ (let ((left-tree (car left-result))
+ (non-left-elts (cdr left-result))
+ (right-size (- n (+ left-size 1))))
+ (let ((this-entry (car non-left-elts))
+ (right-result (partial-tree (cdr non-left-elts) right-size)))
+ (let ((right-tree (car right-result))
+ (remaining-elts (cdr right-result)))
+ (cons (make-tree this-entry left-tree right-tree)
+ remaining-elts))))))))
blob - /dev/null
blob + 1b01040857912da11f6aabc88fc5b5fed97de149 (mode 644)
--- /dev/null
+++ ex2-64-sol.scm~
+(define (entry tree) (car tree))
+(define (left-branch tree) (cadr tree))
+(define (right-branch tree) (caddr tree))
+(define (make-tree entry left right)
+ (list entry left right))
+
+(define (element-of-set? x set)
+ (cond ((null? set) #f)
+ ((= x (entry set)) #t)
+ ((< x (entry set))
+ (element-of-set? x (left-branch set)))
+ ((> x (entry set))
+ (element-of-set? x (right-branch set)))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (make-tree x '() '()))
+ ((= x (entry set)) set)
+ ((< x (entry set))
+ (make-tree (entry set)
+ (adjoin-set x (left-branch set))
+ (right-branch set)))
+ ((> x (entry set))
+ (make-tree (entry set)
+ (left-branch set)
+ (adjoin-set x (right-branch set))))))
+(define (tree->list-1 tree)
+ (if (null? tree)
+ '()
+ (append (tree->list-1 (left-branch tree))
+ (cons (entry tree)
+ (tree->list-1 (right-branch tree))))))
+(define (tree->list-2 tree)
+ (define (copy-to-list tree result-list)
+ (if (null? tree)
+ result-list
+ (copy-to-list (left-branch tree)
+ (cons (entry tree)
+ (copy-to-list (right-branch tree)
+ result-list)))))
+ (copy-to-list tree '()))
+
+(define (list->tree elements)
+ (car (partial-tree elements (length elements))))
+
+(define (partial-tree elts n)
+ (if (= n 0)
+ (cons '() elts)
+ (let ((left-size (quotient (- n 1) 2)))
+ (let ((left-result (partial-tree elts left-size)))
+ (let ((left-tree (car left-result))
+ (non-left-elts (cdr left-result))
+ (right-size (- n (+ left-size 1))))
+ (let ((this-entry (car non-left-elts))
+ (right-result (partial-tree (cdr non-left-elts)
+ right-size)))
+ (let ((right-tree (car right-result))
+ (remaining-elts (cdr right-result)))
+ (cons (make-tree this-entry left-tree right-tree)
+ remaining-elts))))))))
+
+;; a. Write a short paragraph explaining as clearly as you can how partial-tree works. Draw the tree produced by list->tree for the list (1 3 5 7 9 11).
+
+;; If we want a tree with 0 elements in it, we just return an empty tree (nil). Otherwise, we're going to build a tree by finding the middle element of a list rounded down (so if we had 6 elements, the middle element will be 3. If we have 7 elements, it will be 4). We then create a tree with the middle element as the entry of the tree and then call ourselves recursively to build the left-branch of the tree and the right-branch of the tree. We then return this tree along with any elements that have not been put into the tree. The reason we need the remaining elements is because it helps us quickly pass along all the elements of the list that go into the entry and right branch of the tree.
+
+;; b. What is the order of growth in the number of steps required by list->tree to convert a list of n elements?
+
+;; We call partial-tree O(n) times for a list of n elements (a bit more again because we also call it when n = 0). It looks like the order of growth is roughly O(n).
blob - /dev/null
blob + 92ca09ffa4830153458b67c6bcd57df6b6ba6d9f (mode 644)
--- /dev/null
+++ ex2-64.lisp
+(defun partial-tree
blob - /dev/null
blob + cea74c0cf0c339042170e0728c45f12e0e60c9eb (mode 644)
--- /dev/null
+++ ex2-64.scm
+(define (entry tree) (car tree))
+(define (left-branch tree) (cadr tree))
+(define (right-branch tree) (caddr tree))
+(define (make-tree entry left right)
+ (list entry left right))
+
+(define (element-of-set? x set)
+ (cond ((null? set) #f)
+ ((= x (entry set)) #t)
+ ((< x (entry set))
+ (element-of-set? x (left-branch set)))
+ ((> x (entry set))
+ (element-of-set? x (right-branch set)))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (make-tree x '() '()))
+ ((= x (entry set)) set)
+ ((< x (entry set))
+ (make-tree (entry set)
+ (adjoin-set x (left-branch set))
+ (right-branch set)))
+ ((> x (entry set))
+ (make-tree (entry set)
+ (left-branch set)
+ (adjoin-set x (right-branch set))))))
+(define (tree->list-1 tree)
+ (if (null? tree)
+ '()
+ (append (tree->list-1 (left-branch tree))
+ (cons (entry tree)
+ (tree->list-1 (right-branch tree))))))
+(define (tree->list-2 tree)
+ (define (copy-to-list tree result-list)
+ (if (null? tree)
+ result-list
+ (copy-to-list (left-branch tree)
+ (cons (entry tree)
+ (copy-to-list (right-branch tree)
+ result-list)))))
+ (copy-to-list tree '()))
+
+(define (list->tree elements)
+ (car (partial-tree elements (length elements))))
+
+(define (partial-tree elts n)
+ (if (= n 0)
+ (cons '() elts)
+ (let ((left-size (quotient (- n 1) 2)))
+ (let ((left-result (partial-tree elts left-size)))
+ (let ((left-tree (car left-result))
+ (non-left-elts (cdr left-result))
+ (right-size (- n (+ left-size 1))))
+ (let ((this-entry (car non-left-elts))
+ (right-result (partial-tree (cdr non-left-elts)
+ right-size)))
+ (let ((right-tree (car right-result))
+ (remaining-elts (cdr right-result)))
+ (cons (make-tree this-entry left-tree right-tree)
+ remaining-elts))))))))
+
+;; a. Write a short paragraph explaining as clearly as you can how partial-tree works. Draw the tree produced by list->tree for the list (1 3 5 7 9 11).
+
+;; If we want a tree with 0 elements in it, we just return an empty tree (nil). Otherwise, we're going to build a tree by finding the middle element of a list rounded down (so if we had 6 elements, the middle element will be 3. If we have 7 elements, it will be 4). We then create a tree with the middle element as the entry of the tree and then call ourselves recursively to build the left-branch of the tree and the right-branch of the tree. We then return this tree along with any elements that have not been put into the tree. The reason we need the remaining elements is because it helps us quickly pass along all the elements of the list that go into the entry and right branch of the tree.
+
+;; b. What is the order of growth in the number of steps required by list->tree to convert a list of n elements?
+
+;; We call partial-tree O(n) times for a list of n elements (a bit more again because we also call it when n = 0). It looks like the order of growth is roughly O(n).
+
+(define (tree->list-1 tree)
+ (if (null? tree)
+ '()
+ (append (tree->list-1 (left-branch tree))
+ (cons (entry tree)
+ (tree->list-1 (right-branch tree))))))
+(define (tree->list-2 tree)
+ (define (cons-tree->list tree larger-items)
+ (if (null? tree)
+ larger-items
+ (cons-tree->list (left-branch tree)
+ (cons (entry tree)
+ (cons-tree->list (right-branch tree)
+ larger-items)))))
+ (cons-tree->list tree '()))
blob - /dev/null
blob + cea74c0cf0c339042170e0728c45f12e0e60c9eb (mode 644)
--- /dev/null
+++ ex2-64.scm~
+(define (entry tree) (car tree))
+(define (left-branch tree) (cadr tree))
+(define (right-branch tree) (caddr tree))
+(define (make-tree entry left right)
+ (list entry left right))
+
+(define (element-of-set? x set)
+ (cond ((null? set) #f)
+ ((= x (entry set)) #t)
+ ((< x (entry set))
+ (element-of-set? x (left-branch set)))
+ ((> x (entry set))
+ (element-of-set? x (right-branch set)))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (make-tree x '() '()))
+ ((= x (entry set)) set)
+ ((< x (entry set))
+ (make-tree (entry set)
+ (adjoin-set x (left-branch set))
+ (right-branch set)))
+ ((> x (entry set))
+ (make-tree (entry set)
+ (left-branch set)
+ (adjoin-set x (right-branch set))))))
+(define (tree->list-1 tree)
+ (if (null? tree)
+ '()
+ (append (tree->list-1 (left-branch tree))
+ (cons (entry tree)
+ (tree->list-1 (right-branch tree))))))
+(define (tree->list-2 tree)
+ (define (copy-to-list tree result-list)
+ (if (null? tree)
+ result-list
+ (copy-to-list (left-branch tree)
+ (cons (entry tree)
+ (copy-to-list (right-branch tree)
+ result-list)))))
+ (copy-to-list tree '()))
+
+(define (list->tree elements)
+ (car (partial-tree elements (length elements))))
+
+(define (partial-tree elts n)
+ (if (= n 0)
+ (cons '() elts)
+ (let ((left-size (quotient (- n 1) 2)))
+ (let ((left-result (partial-tree elts left-size)))
+ (let ((left-tree (car left-result))
+ (non-left-elts (cdr left-result))
+ (right-size (- n (+ left-size 1))))
+ (let ((this-entry (car non-left-elts))
+ (right-result (partial-tree (cdr non-left-elts)
+ right-size)))
+ (let ((right-tree (car right-result))
+ (remaining-elts (cdr right-result)))
+ (cons (make-tree this-entry left-tree right-tree)
+ remaining-elts))))))))
+
+;; a. Write a short paragraph explaining as clearly as you can how partial-tree works. Draw the tree produced by list->tree for the list (1 3 5 7 9 11).
+
+;; If we want a tree with 0 elements in it, we just return an empty tree (nil). Otherwise, we're going to build a tree by finding the middle element of a list rounded down (so if we had 6 elements, the middle element will be 3. If we have 7 elements, it will be 4). We then create a tree with the middle element as the entry of the tree and then call ourselves recursively to build the left-branch of the tree and the right-branch of the tree. We then return this tree along with any elements that have not been put into the tree. The reason we need the remaining elements is because it helps us quickly pass along all the elements of the list that go into the entry and right branch of the tree.
+
+;; b. What is the order of growth in the number of steps required by list->tree to convert a list of n elements?
+
+;; We call partial-tree O(n) times for a list of n elements (a bit more again because we also call it when n = 0). It looks like the order of growth is roughly O(n).
+
+(define (tree->list-1 tree)
+ (if (null? tree)
+ '()
+ (append (tree->list-1 (left-branch tree))
+ (cons (entry tree)
+ (tree->list-1 (right-branch tree))))))
+(define (tree->list-2 tree)
+ (define (cons-tree->list tree larger-items)
+ (if (null? tree)
+ larger-items
+ (cons-tree->list (left-branch tree)
+ (cons (entry tree)
+ (cons-tree->list (right-branch tree)
+ larger-items)))))
+ (cons-tree->list tree '()))
blob - /dev/null
blob + ecaf75569b62d79c7752ab7ebec1619b5e842f70 (mode 644)
--- /dev/null
+++ ex2-65.lisp
+(defun union-set-bintree (set1 set2)
+ (let* ((lset1 (tree->list-1 set1))
+ (lset2 (tree->list-1 set2))
+ (lunion (union-set lset1 lset2))
+ (union (list->tree lunion)))
+ union))
+(defun intersection-set-bintree (set1 set2)
+ (let* ((lset1 (tree->list-1 set1))
+ (lset2 (tree->list-1 set2))
+ (lintersect (intersection-set lset1 lset2))
+ (intersect (list->tree lintersect)))
+ intersect))
+
blob - /dev/null
blob + 63ff6d5707449a6d620a0938de2364612dca38f8 (mode 644)
--- /dev/null
+++ ex2-65.lisp~
+(defun union-set-bintree (set1 set2)
+ (let* ((lset1 (tree->list-1 set1
blob - /dev/null
blob + af81dd6ec266bc944ceb448e2017c4efefa81f2a (mode 644)
--- /dev/null
+++ ex2-65.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+
+(define (entry tree) (car tree))
+(define (left-branch tree) (cadr tree))
+(define (right-branch tree) (caddr tree))
+(define (make-tree entry left right)
+ (list entry left right))
+
+(define (element-of-set? x set)
+ (cond ((null? set) #f)
+ ((= x (entry set)) #t)
+ ((< x (entry set))
+ (element-of-set? x (left-branch set)))
+ ((> x (entry set))
+ (element-of-set? x (right-branch set)))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (make-tree x '() '()))
+ ((= x (entry set)) set)
+ ((< x (entry set))
+ (make-tree (entry set)
+ (adjoin-set x (left-branch set))
+ (right-branch set)))
+ ((> x (entry set))
+ (make-tree (entry set)
+ (left-branch set)
+ (adjoin-set x (right-branch set))))))
+
+(define (tree->list-2 tree)
+ (define (copy-to-list tree result-list)
+ (if (null? tree)
+ result-list
+ (copy-to-list (left-branch tree)
+ (cons (entry tree)
+ (copy-to-list (right-branch tree)
+ result-list)))))
+ (copy-to-list tree '()))
+
+(define (list->tree elements)
+ (car (partial-tree elements (length elements))))
+
+(define (partial-tree elts n)
+ (if (= n 0)
+ (cons '() elts)
+ (let* ((left-size (quotient (- n 1) 2))
+ (left-results (partial-tree elts left-size))
+ (left-tree (car left-results))
+ (right-size (- n (+ left-size 1)))
+ (right-result (partial-tree (cddr left-results) right-size))
+ (right-tree (car right-result)))
+ (cons (make-tree (cadr left-results)
+ left-tree
+ right-tree)
+ (cdr right-result)))))
+
+(test-case (list->tree '()) '())
+(test-case (list->tree '(1)) '(1 () ()))
+(test-case (list->tree '(1 2 3 4 5 6 7 8 9 10))
+ '(5 (2 (1 () ()) (3 () (4 () ()))) (8 (6 () (7 () ())) (9 () (10 () ())))))
+
+
+;; Exercise 2.65. Use the results of exercises 2.63 and 2.64 to give O(n) implementations of union-set and intersection-set for sets implemented as (balanced) binary trees.
+
+(define (union-set set1 set2)
+ (define (union-set-list list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else
+ (let ((l1 (car list1))
+ (l2 (car list2)))
+ (cond ((= l1 l2)
+ (cons l1 (union-set-list (cdr list1) (cdr list2))))
+ ((< l1 l2)
+ (cons l1 (union-set-list (cdr list1) list2)))
+ ((> l1 l2)
+ (cons l2 (union-set-list list1 (cdr list2)))))))))
+ (list->tree (union-set-list (tree->list-2 set1)
+ (tree->list-2 set2))))
+
+
+(test-case (union-set '() '()) '())
+(test-case (union-set (make-tree 5 '() '()) '()) '(5 () ()))
+(test-case (union-set '() (make-tree 5 (make-tree 3 '() '()) (make-tree 7 '() '()))) '(5 (3 () ()) (7 () ())))
+(test-case
+ (union-set
+ (make-tree 3
+ (make-tree 1
+ (make-tree 0 '() '())
+ (make-tree 2 '() '()))
+ (make-tree 5
+ (make-tree 4 '() '())
+ (make-tree 6 '() '())))
+ (make-tree 1
+ '()
+ (make-tree 3
+ '()
+ (make-tree 5
+ '()
+ (make-tree 7
+ '()
+ (make-tree 9
+ '()
+ '()))))))
+ '(4 (1 (0 () ()) (2 () (3 () ()))) (6 (5 () ()) (7 () (9 () ())))))
+(test-case
+ (union-set
+ '(3 (1 (0 () ())
+ (2 () ()))
+ (5 (4 () ())
+ (6 () ())))
+ '(1 () (3 () (5 () (7 () (9 () ()))))))
+ '(4 (1 (0 () ()) (2 () (3 () ()))) (6 (5 () ()) (7 () (9 () ())))))
+(test-case
+ (union-set
+ '(1 () (2 () (3 () (5 (4 () ()) (10 (8 (7 () ()) ()) (12 (11 () ()) (14 () ())))))))
+ '(11 (4 (3 (2 () ()) ()) (9 () ())) (12 () (15 (14 (13 () ()) ()) ()))))
+ '(8 (3 (1 () (2 () ())) (5 (4 () ()) (7 () ()))) (12 (10 (9 () ()) (11 () ())) (14 (13 () ()) (15 () ())))))
+
+(define (intersection-set set1 set2)
+ (define (intersection-list list1 list2)
+ (if (or (null? list1)
+ (null? list2))
+ '()
+ (let ((l1 (car list1))
+ (l2 (car list2)))
+ (cond ((= l1 l2) (cons l1 (intersection-list (cdr list1) (cdr list2))))
+ ((< l1 l2) (intersection-list (cdr list1) list2))
+ ((> l1 l2) (intersection-list list1 (cdr list2)))))))
+ (list->tree (intersection-list (tree->list-2 set1)
+ (tree->list-2 set2))))
+
+(test-case (intersection-set '() '()) '())
+(test-case (intersection-set '(5 () ())
+ '())
+ '())
+(test-case (intersection-set '()
+ '(5 () ()))
+ '())
+(test-case (intersection-set
+ '(3 () ())
+ '(5 (3 () ()) (7 () ())))
+ '(3 () ()))
+(test-case (intersection-set
+ '(3 (1 (0 () ()) (2 () ())) (5 (4 () ()) (6 () ())))
+ '(1 () (3 () (5 () (7 () (9 () ()))))))
+ '(3 (1 () ()) (5 () ())))
+(test-case
+ (intersection-set
+ '(1 () (2 () (3 () (5 (4 () ()) (10 (8 (7 () ()) ()) (12 (11 () ()) (14 () ())))))))
+ '(11 (4 (3 (2 () ()) ()) (9 () ())) (12 () (15 (14 (13 () ()) ()) ()))))
+ '(4 (2 () (3 () ())) (12 (11 () ()) (14 () ()))))
+
blob - /dev/null
blob + 7ac142753e517868aa45d4262b1babc4eff1fb56 (mode 644)
--- /dev/null
+++ ex2-65.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+
+(define (entry tree) (car tree))
+(define (left-branch tree) (cadr tree))
+(define (right-branch tree) (caddr tree))
+(define (make-tree entry left right)
+ (list entry left right))
+
+(define (element-of-set? x set)
+ (cond ((null? set) #f)
+ ((= x (entry set)) #t)
+ ((< x (entry set))
+ (element-of-set? x (left-branch set)))
+ ((> x (entry set))
+ (element-of-set? x (right-branch set)))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (make-tree x '() '()))
+ ((= x (entry set)) set)
+ ((< x (entry set))
+ (make-tree (entry set)
+ (adjoin-set x (left-branch set))
+ (right-branch set)))
+ ((> x (entry set))
+ (make-tree (entry set)
+ (left-branch set)
+ (adjoin-set x (right-branch set))))))
+(define (tree->list-1 tree)
+ (if (null? tree)
+ '()
+ (append (tree->list-1 (left-branch tree))
+ (cons (entry tree)
+ (tree->list-1 (right-branch tree))))))
+(define (tree->list-2 tree)
+ (define (copy-to-list tree result-list)
+ (if (null? tree)
+ result-list
+ (copy-to-list (left-branch tree)
+ (cons (entry tree)
+ (copy-to-list (right-branch tree)
+ result-list)))))
+ (copy-to-list tree '()))
+
+(define (list->tree elements)
+ (car (partial-tree elements (length elements))))
+
+(define (partial-tree elts n)
+ (if (= n 0)
+ (cons '() elts)
+ (let ((left-size (quotient (- n 1) 2)))
+ (let ((left-result (partial-tree elts left-size)))
+ (let ((left-tree (car left-result))
+ (non-left-elts (cdr left-result))
+ (right-size (- n (+ left-size 1))))
+ (let ((this-entry (car non-left-elts))
+ (right-result (partial-tree (cdr non-left-elts)
+ right-size)))
+ (let ((right-tree (car right-result))
+ (remaining-elts (cdr right-result)))
+ (cons (make-tree this-entry left-tree right-tree)
+ remaining-elts))))))))
+
+;; Exercise 2.65. Use the results of exercises 2.63 and 2.64 to give (n) implementations of union-set and intersection-set for sets implemented as (balanced) binary trees.41
+
+(define (union-set set1 set2)
+ (define (union-set-list list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else
+ (let ((l1 (car list1))
+ (l2 (car list2)))
+ (cond ((= l1 l2)
+ (cons l1 (union-set-list (cdr list1) (cdr list2))))
+ ((< l1 l2)
+ (cons l1 (union-set-list (cdr list1) list2)))
+ ((> l1 l2)
+ (cons l2 (union-set-list list1 (cdr list2)))))))))
+ (list->tree (union-set-list (tree->list-2 set1)
+ (tree->list-2 set2))))
+
+
+(test-case (union-set '() '()) '())
+(test-case (union-set (make-tree 5 '() '()) '()) '(5 () ()))
+(test-case (union-set '() (make-tree 5 (make-tree 3 '() '()) (make-tree 7 '() '()))) '(5 (3 () ()) (7 () ())))
+(test-case
+ (union-set
+ (make-tree 3
+ (make-tree 1
+ (make-tree 0 '() '())
+ (make-tree 2 '() '()))
+ (make-tree 5
+ (make-tree 4 '() '())
+ (make-tree 6 '() '())))
+ (make-tree 1
+ '()
+ (make-tree 3
+ '()
+ (make-tree 5
+ '()
+ (make-tree 7
+ '()
+ (make-tree 9
+ '()
+ '()))))))
+ '(4 (1 (0 () ()) (2 () (3 () ()))) (6 (5 () ()) (7 () (9 () ())))))
+(test-case
+ (union-set
+ (make-tree 3
+ (make-tree 1
+ (make-tree 0 '() '())
+ (make-tree 2 '() '()))
+ (make-tree 5
+ (make-tree 4 '() '())
+ (make-tree 6 '() '())))
+ (make-tree 1
+ '()
+ (make-tree 3
+ '()
+ (make-tree 5
+ '()
+ (make-tree 7
+ '()
+ (make-tree 9
+ '()
+ '()))))))
+ '(4 (1 (0 () ()) (2 () (3 () ()))) (6 (5 () ()) (7 () (9 () ())))))
+(test-case
+ (union-set
+ '(1 () (2 () (3 () (5 (4 () ()) (10 (8 (7 () ()) ()) (12 (11 () ()) (14 () ())))))))
+ '(11 (4 (3 () (2 () ())) (9 () ())) (12 () (15 (14 (13 () ()) ()) ()))))
+ '(8 (3 (1 () (2 () ())) (5 (4 () ()) (7 () ()))) (12 (10 (9 () ()) (11 () ())) (14 (13 () ()) (15 () ())))))
+
+ (make-tree 0 '() '())
+ (make-tree 2 '() '()))
+ (make-tree 5
+ (make-tree 4 '() '())
+ (make-tree 6 '() '())))
blob - /dev/null
blob + 233892455ea8c7e73a767f3c068075b6084052f5 (mode 644)
--- /dev/null
+++ ex2-66.lisp
+(defun lookup (given-key set)
+ (if (null? set)
+ nil
+ (let* ((cur-entry (entry set))
+ (cur-key (key cur-entry)))
+ (cond ((= cur-key given-key) cur-entry)
+ ((< given-key cur-key)
+ (lookup given-key (left-branch set)))
+ ((> given-key cur-key)
+ (lookup
+ given-key
+ (right-branch set)))))))
+
+(defun make-record (key data)
+ (list key data))
+(defun key (record)
+ (car record))
+(defun data (record)
+ (cadr record))
blob - /dev/null
blob + 085d11dc92663c04bbb8ea465eda928912b58180 (mode 644)
--- /dev/null
+++ ex2-66.lisp~
+(defun lookup (given-key set)
+ (if (null? set)
+ nil
+ (let* ((cur-entry (entry set))
+ (cur-key (key cur-entry)))
+ (cond ((= cur-key given-key) cur-entry)
+ ((< given-key cur-key)
+ (lookup given-key (left-branch set)))
+ ((> given-key cur-key)
+ (lookup
+ given-key
+ (right-branch set)))))))
blob - /dev/null
blob + 6413db8b56bb66687dda878bc515a2e7d3a12af0 (mode 644)
--- /dev/null
+++ ex2-66.scm
+(define (entry tree) (car tree))
+(define (left-branch tree) (cadr tree))
+(define (right-branch tree) (caddr tree))
+(define (make-tree entry left right)
+ (list entry left right))
+
+(define (element-of-set? x set)
+ (cond ((null? set) #f)
+ ((= x (entry set)) #t)
+ ((< x (entry set))
+ (element-of-set? x (left-branch set)))
+ ((> x (entry set))
+ (element-of-set? x (right-branch set)))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (make-tree x '() '()))
+ ((= x (entry set)) set)
+ ((< x (entry set))
+ (make-tree (entry set)
+ (adjoin-set x (left-branch set))
+ (right-branch set)))
+ ((> x (entry set))
+ (make-tree (entry set)
+ (left-branch set)
+ (adjoin-set x (right-branch set))))))
+
+;; Exercise 2.66. Implement the lookup procedure for the case where the set of records is structured as a binary tree, ordered by the numerical values of the keys.
+
+(define (lookup given-key set-of-records)
+ (if (null? set-of-records)
+ #f
+ (let ((record (entry set-of-records))
+ (record-key (key record)))
+ (cond ((= given-key record-key)
+ record)
+ ((< given-key record-key)
+ (lookup given-key (left-branch set-of-records)))
+ ((> given-key record-key)
+ (lookup given-key (right-branch set-of-records)))))))
blob - /dev/null
blob + ae6b838a5e2eda609237c090ad14234ebe310022 (mode 644)
--- /dev/null
+++ ex2-66.scm~
+(define (lookup given-key set-of-records)
+ (cond ((null? set-of-records) false)
+ ((equal? given
blob - /dev/null
blob + f2c9e7fe09bf94c3c8765eee73627527d94d27b8 (mode 644)
--- /dev/null
+++ ex2-67.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-leaf symbol weight)
+ (list 'leaf symbol weight))
+(define (leaf? object)
+ (eq? (car object) 'leaf))
+(define (symbol-leaf x) (cadr x))
+(define (weight-leaf x) (caddr x))
+
+(define (make-code-tree left right)
+ (list left
+ right
+ (append (symbols left) (symbols right))
+ (+ (weight left) (weight right))))
+
+(define (left-branch tree) (car tree))
+(define (right-branch tree) (cadr tree))
+(define (symbols tree)
+ (if (leaf? tree)
+ (list (symbol-leaf tree))
+ (caddr tree)))
+(define (weight tree)
+ (if (leaf? tree)
+ (weight-leaf tree)
+ (cadddr tree)))
+
+(define (decode bits tree)
+ (define (decode-1 bits current-branch)
+ (if (null? bits)
+ '()
+ (let ((next-branch
+ (choose-branch (car bits) current-branch)))
+ (if (leaf? next-branch)
+ (cons (symbol-leaf next-branch)
+ (decode-1 (cdr bits) tree))
+ (decode-1 (cdr bits) next-branch)))))
+ (decode-1 bits tree))
+(define (choose-branch bit branch)
+ (cond ((= bit 0) (left-branch branch))
+ ((= bit 1) (right-branch branch))
+ (else (error "bad bit -- CHOOSE-BRANCH" bit))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((< (weight x) (weight (car set))) (cons x set))
+ (else (cons (car set)
+ (adjoin-set x (cdr set))))))
+(define (make-leaf-set pairs)
+ (if (null? pairs)
+ '()
+ (let ((pair (car pairs)))
+ (adjoin-set (make-leaf (car pair)
+ (cadr pair))
+ (make-leaf-set (cdr pairs))))))
+
+;; Exercise 2.67. Define an encoding tree and a sample message:
+
+(define sample-tree
+ (make-code-tree (make-leaf 'A 4)
+ (make-code-tree
+ (make-leaf 'B 2)
+ (make-code-tree (make-leaf 'D 1)
+ (make-leaf 'C 1)))))
+
+(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
+(test-case (decode sample-message sample-tree) '(A D A B B C A))
blob - /dev/null
blob + 3b4dbc4053a4d3697b98a9b78c76b75b066e6ef4 (mode 644)
--- /dev/null
+++ ex2-67.scm~
+(define (make-leaf symbol weight)
+ (list 'leaf symbol weight))
+(define (leaf? object)
+ (eq? (car object) 'leaf))
+(define (symbol-leaf x) (cadr x))
+(define (weight-leaf x) (caddr x))
+
+(define (make-code-tree left right)
+ (list left
+ right
+ (append (symbols left) (symbols right))
+ (+ (weight left) (weight right))))
+
+(define (left-branch tree) (car tree))
+(define (right-branch tree) (cadr tree))
+(define (symbols tree)
+ (if (leaf? tree)
+ (list (symbol-leaf tree))
+ (caddr tree)))
+(define (weight tree)
+ (if (leaf? tree)
+ (weight-leaf tree)
+ (cadddr tree)))
+
+(define (decode bits tree)
+ (define (decode-1 bits branch)
+ (cond ((if (and (null? bits)
+ (leaf? branch))
+ (list (symbol-leaf branch))
+ ;; ((null? branch)
+ ;; ("error: symbol not found"))
+ ((leaf? branch)
+ (cons (symbol-leaf branch)
+ (decode-1 (cdr bits)
+ (choose-branch (car bits) tree))))
+ (else (decode-1 (cdr bits)
+ (choose-branch (car bits) branch)))))
+ (decode-1 bits tree))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+(define (decode bits tree)
+ (define (decode-1 bits current-branch)
+ (if (null? bits)
+ '()
+ (let ((next-branch
+ (choose-branch (car bits) current-branch)))
+ (if (leaf? next-branch)
+ (cons (symbol-leaf next-branch)
+ (decode-1 (cdr bits) tree))
+ (decode-1 (cdr bits) next-branch)))))
+ (decode-1 bits tree))
+(define (choose-branch bit branch)
+ (cond ((= bit 0) (left-branch branch))
+ ((= bit 1) (right-branch branch))
+ (else (error "bad bit -- CHOOSE-BRANCH" bit))))
blob - /dev/null
blob + 735a5ad1d7320578e7dbdf5d670d0b7c80664846 (mode 644)
--- /dev/null
+++ ex2-68.lisp
+(load "common")
+(defun make-leaf (symbol weight)
+ (list 'leaf sym weight))
+(defun leaf? (obj)
+ (eq (car obj) 'leaf))
+(defun symbol-leaf (x)
+ (cadr x))
+(defun weight-leaf (x)
+ (caddr x))
+(defun make-code-tree (left right)
+ (list left
+ right
+ (append (symbols left) (symbols right))
+ (+ (weight left) (weight right))))
+(defun left-branch (tree)
+ (car tree))
+(defun right-branch (tree)
+ (cadr tree))
+(defun symbols (tree)
+ (if (leaf? tree)
+ (list (symbol-leaf tree))
+ (caddr tree)))
+(defun weight (tree)
+ (if (leaf? tree)
+ (weight-leaf tree)
+ (cadddr tree)))
+(defun adjoin-set (x set)
+ "Add a new element _x_ into a set of elements, sorted by weight"
+ (cond ((null set) (list x))
+ ((< (weight x) (weight (car set)))
+ (cons x set))
+ (t (cons (car set)
+ (adjoin-set x (cdr set))))))
+(defun make-leaf-set (pairs)
+ (if (null pairs)
+ '()
+ (let ((pair (car pairs)))
+ (adjoin-set (make-leaf (car pair)
+ (cadr pair))
+ (make-leaf-set (cdr pairs))))))
+(defun decode (bits tree)
+ (labels ((decode-1 (bits branch)
+ (if (null bits)
+ '()
+ (let ((next-branch (choose-branch (car bits) branch)))
+ (if (leaf? next-branch)
+ (cons (symbol-leaf next-branch)
+ (decode-1 (cdr bits) tree))
+ (decode-1 (cdr bits) next-branch))))))
+ (decode-1 bits tree)))
+(defun choose-branch (bit branch)
+ (cond ((= bit 0) (left-branch branch))
+ ((= bit 1) (right-branch branch))
+ (t (error "bad bit -- CHOOSE-BRANCH ~A" bit))))
+
+(defvar sample-tree
+ (make-code-tree
+ (make-leaf 'A 4)
+ (make-code-tree
+ (make-leaf 'B 2)
+ (make-code-tree
+ (make-leaf 'D 1)
+ (make-leaf 'C 2)))))
+(defvar sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
+
+(defun encode-symbol (sym tree)
+ (labels ((tree-walk (sym node encoding)
+ (if (leaf? node)
+ encoding
+ (cond
+ ((element-of-set? sym (symbols (left-branch node)))
+ (tree-walk sym (left-branch node) (cons 0 encoding)))
+ ((element-of-set? sym (symbols (right-branch node)))
+ (tree-walk sym (right-branch node) (cons 1 encoding)))
+ (t (error "Symbol not in tree -- ~A" sym))))))
+ (reverse (tree-walk sym tree '()))))
blob - /dev/null
blob + 9962c9b410a9096b91ba49613dc2b90444863551 (mode 644)
--- /dev/null
+++ ex2-68.lisp~
+(load "common")
+(defun make-leaf (symbol weight)
+ (list 'leaf sym weight))
+(defun leaf? (obj)
+ (eq (car obj) 'leaf))
+(defun symbol-leaf (x)
+ (cadr x))
+(defun weight-leaf (x)
+ (caddr x))
+(defun make-code-tree (left right)
+ (list left
+ right
+ (append (symbols left) (symbols right))
+ (+ (weight left) (weight right))))
+(defun left-branch (tree)
+ (car tree))
+(defun right-branch (tree)
+ (cadr tree))
+(defun symbols (tree)
+ (if (leaf? tree)
+ (list (symbol-leaf tree))
+ (caddr tree)))
+(defun weight (tree)
+ (if (leaf? tree)
+ (weight-leaf tree)
+ (cadddr tree)))
+(defun adjoin-set (x set)
+ "Add a new element _x_ into a set of elements, sorted by weight"
+ (cond ((null set) (list x))
+ ((< (weight x) (weight (car set)))
+ (cons x set))
+ (t (cons (car set)
+ (adjoin-set x (cdr set))))))
blob - /dev/null
blob + 8ae8fea1e82f219528c65eb5853fb3e1ba94a495 (mode 644)
--- /dev/null
+++ ex2-68.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-leaf symbol weight)
+ (list 'leaf symbol weight))
+(define (leaf? object)
+ (eq? (car object) 'leaf))
+(define (symbol-leaf x) (cadr x))
+(define (weight-leaf x) (caddr x))
+
+(define (make-code-tree left right)
+ (list left
+ right
+ (append (symbols left) (symbols right))
+ (+ (weight left) (weight right))))
+
+(define (left-branch tree) (car tree))
+(define (right-branch tree) (cadr tree))
+(define (symbols tree)
+ (if (leaf? tree)
+ (list (symbol-leaf tree))
+ (caddr tree)))
+(define (weight tree)
+ (if (leaf? tree)
+ (weight-leaf tree)
+ (cadddr tree)))
+
+(define (decode bits tree)
+ (define (decode-1 bits current-branch)
+ (if (null? bits)
+ '()
+ (let ((next-branch
+ (choose-branch (car bits) current-branch)))
+ (if (leaf? next-branch)
+ (cons (symbol-leaf next-branch)
+ (decode-1 (cdr bits) tree))
+ (decode-1 (cdr bits) next-branch)))))
+ (decode-1 bits tree))
+(define (choose-branch bit branch)
+ (cond ((= bit 0) (left-branch branch))
+ ((= bit 1) (right-branch branch))
+ (else (error "bad bit -- CHOOSE-BRANCH" bit))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((< (weight x) (weight (car set))) (cons x set))
+ (else (cons (car set)
+ (adjoin-set x (cdr set))))))
+(define (make-leaf-set pairs)
+ (if (null? pairs)
+ '()
+ (let ((pair (car pairs)))
+ (adjoin-set (make-leaf (car pair)
+ (cadr pair))
+ (make-leaf-set (cdr pairs))))))
+
+;; Exercise 2.68. The encode procedure takes as arguments a message and a tree and produces the list of bits that gives the encoded message.
+
+(define (encode message tree)
+ (if (null? message)
+ '()
+ (append (encode-symbol (car message) tree)
+ (encode (cdr message) tree))))
+
+(define (element-of-set x set)
+ (and (not (null? set))
+ (or (equal? x (car set))
+ (element-of-set x (cdr set)))))
+
+;; (test-case (element-of-set 'A '()) #f)
+;; (test-case (element-of-set 'A '(1 B C D)) #f)
+;; (test-case (element-of-set 'A '(1 A B C)) #t)
+
+(define (encode-symbol sym tree)
+ (cond ((null? tree) (error "empty tree"))
+ ((not (element-of-set sym (symbols tree)))
+ (error "symbol not in tree"))
+ ((leaf? tree) '())
+ ((element-of-set sym (symbols (left-branch tree)))
+ (cons 0 (encode-symbol sym (left-branch tree))))
+ ((element-of-set sym (symbols (right-branch tree)))
+ (cons 1 (encode-symbol sym (right-branch tree))))))
+
+;; (define (encode-symbol sym tree)
+;; (cond ((null? tree) (error "empty tree"))
+;; ((leaf? tree) '())
+;; ((element-of-set sym (symbols (left-branch tree)))
+;; (cons 0 (encode-symbol sym (left-branch tree))))
+;; ((element-of-set sym (symbols (right-branch tree)))
+;; (cons 1 (encode-symbol sym (right-branch tree))))
+;; (else (error "symbol not in tree")))))
+
+;; Encode-symbol is a procedure, which you must write, that returns the list of bits that encodes a given symbol according to a given tree. You should design encode-symbol so that it signals an error if the symbol is not in the tree at all. Test your procedure by encoding the result you obtained in exercise 2.67 with the sample tree and seeing whether it is the same as the original sample message.
+
+(define sample-tree
+ (make-code-tree (make-leaf 'A 4)
+ (make-code-tree
+ (make-leaf 'B 2)
+ (make-code-tree (make-leaf 'D 1)
+ (make-leaf 'C 1)))))
+(define sample-tree-2
+ (make-code-tree (make-leaf 'A 4)
+ (make-code-tree
+ (make-leaf 'B 2)
+ (make-code-tree (make-leaf 'E 1)
+ (make-leaf 'C 1)))))
+
+(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
+(define sample-message-2 '(1 1 0 1 1 1 1 0 0 1 0 1 1 0 1 1 0 0 1 0 1 0 0 0 1 1 1 0))
+(define sample-symbols '(A D A B B C A))
+(define sample-symbols-2 '(E C B A B E E A B B A A C A))
+(test-case (decode sample-message sample-tree) sample-symbols)
+
+(test-case (encode (decode sample-message sample-tree) sample-tree) sample-message)
+;; (test-case (encode sample-symbols '()) "error: empty tree")
+;; (test-case (encode sample-symbols sample-tree-2) "error: symbol not in tree")
+(test-case (encode sample-symbols-2 sample-tree-2) sample-message-2)
+(test-case (decode (encode sample-symbols-2 sample-tree-2) sample-tree-2) sample-symbols-2)
blob - /dev/null
blob + f2c9e7fe09bf94c3c8765eee73627527d94d27b8 (mode 644)
--- /dev/null
+++ ex2-68.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-leaf symbol weight)
+ (list 'leaf symbol weight))
+(define (leaf? object)
+ (eq? (car object) 'leaf))
+(define (symbol-leaf x) (cadr x))
+(define (weight-leaf x) (caddr x))
+
+(define (make-code-tree left right)
+ (list left
+ right
+ (append (symbols left) (symbols right))
+ (+ (weight left) (weight right))))
+
+(define (left-branch tree) (car tree))
+(define (right-branch tree) (cadr tree))
+(define (symbols tree)
+ (if (leaf? tree)
+ (list (symbol-leaf tree))
+ (caddr tree)))
+(define (weight tree)
+ (if (leaf? tree)
+ (weight-leaf tree)
+ (cadddr tree)))
+
+(define (decode bits tree)
+ (define (decode-1 bits current-branch)
+ (if (null? bits)
+ '()
+ (let ((next-branch
+ (choose-branch (car bits) current-branch)))
+ (if (leaf? next-branch)
+ (cons (symbol-leaf next-branch)
+ (decode-1 (cdr bits) tree))
+ (decode-1 (cdr bits) next-branch)))))
+ (decode-1 bits tree))
+(define (choose-branch bit branch)
+ (cond ((= bit 0) (left-branch branch))
+ ((= bit 1) (right-branch branch))
+ (else (error "bad bit -- CHOOSE-BRANCH" bit))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((< (weight x) (weight (car set))) (cons x set))
+ (else (cons (car set)
+ (adjoin-set x (cdr set))))))
+(define (make-leaf-set pairs)
+ (if (null? pairs)
+ '()
+ (let ((pair (car pairs)))
+ (adjoin-set (make-leaf (car pair)
+ (cadr pair))
+ (make-leaf-set (cdr pairs))))))
+
+;; Exercise 2.67. Define an encoding tree and a sample message:
+
+(define sample-tree
+ (make-code-tree (make-leaf 'A 4)
+ (make-code-tree
+ (make-leaf 'B 2)
+ (make-code-tree (make-leaf 'D 1)
+ (make-leaf 'C 1)))))
+
+(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
+(test-case (decode sample-message sample-tree) '(A D A B B C A))
blob - /dev/null
blob + 05c25f89087f2829d45747139bb342a1cedb973b (mode 644)
--- /dev/null
+++ ex2-69.lisp
+(defun generate-huffman-tree (pairs)
+ (successive-merge (make-leaf-set pairs)))
+(defun successive-merge (node-set)
+ (if (null (cadr node-set))
+ (car node-set)
+ (successive-merge
+ (adjoin-set (make-code-tree (car node-set)
+ (cadr node-set))
+ (cddr node-set)))))
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 179fc78f1abdb3aed52fc45f412afdf863975fff (mode 644)
--- /dev/null
+++ ex2-69.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-leaf symbol weight)
+ (list 'leaf symbol weight))
+(define (leaf? object)
+ (eq? (car object) 'leaf))
+(define (symbol-leaf x) (cadr x))
+(define (weight-leaf x) (caddr x))
+
+(define (make-code-tree left right)
+ (list left
+ right
+ (append (symbols left) (symbols right))
+ (+ (weight left) (weight right))))
+
+(define (left-branch tree) (car tree))
+(define (right-branch tree) (cadr tree))
+(define (symbols tree)
+ (if (leaf? tree)
+ (list (symbol-leaf tree))
+ (caddr tree)))
+(define (weight tree)
+ (if (leaf? tree)
+ (weight-leaf tree)
+ (cadddr tree)))
+
+(define (decode bits tree)
+ (define (decode-1 bits current-branch)
+ (if (null? bits)
+ '()
+ (let ((next-branch
+ (choose-branch (car bits) current-branch)))
+ (if (leaf? next-branch)
+ (cons (symbol-leaf next-branch)
+ (decode-1 (cdr bits) tree))
+ (decode-1 (cdr bits) next-branch)))))
+ (decode-1 bits tree))
+(define (choose-branch bit branch)
+ (cond ((= bit 0) (left-branch branch))
+ ((= bit 1) (right-branch branch))
+ (else (error "bad bit -- CHOOSE-BRANCH" bit))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((< (weight x) (weight (car set))) (cons x set))
+ (else (cons (car set)
+ (adjoin-set x (cdr set))))))
+(define (make-leaf-set pairs)
+ (if (null? pairs)
+ '()
+ (let ((pair (car pairs)))
+ (adjoin-set (make-leaf (car pair)
+ (cadr pair))
+ (make-leaf-set (cdr pairs))))))
+
+(define (encode message tree)
+ (if (null? message)
+ '()
+ (append (encode-symbol (car message) tree)
+ (encode (cdr message) tree))))
+
+(define (element-of-set x set)
+ (and (not (null? set))
+ (or (equal? x (car set))
+ (element-of-set x (cdr set)))))
+
+(define (encode-symbol sym tree)
+ (cond ((null? tree) (error "empty tree"))
+ ((not (element-of-set sym (symbols tree)))
+ (error "symbol not in tree"))
+ ((leaf? tree) '())
+ ((element-of-set sym (symbols (left-branch tree)))
+ (cons 0 (encode-symbol sym (left-branch tree))))
+ ((element-of-set sym (symbols (right-branch tree)))
+ (cons 1 (encode-symbol sym (right-branch tree))))))
+
+(define sample-tree
+ (make-code-tree (make-leaf 'A 4)
+ (make-code-tree
+ (make-leaf 'B 2)
+ (make-code-tree (make-leaf 'D 1)
+ (make-leaf 'C 1)))))
+(define sample-tree-2
+ (make-code-tree (make-leaf 'A 4)
+ (make-code-tree
+ (make-leaf 'B 2)
+ (make-code-tree (make-leaf 'E 1)
+ (make-leaf 'C 1)))))
+
+(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
+(define sample-message-2 '(1 1 0 1 1 1 1 0 0 1 0 1 1 0 1 1 0 0 1 0 1 0 0 0 1 1 1 0))
+(define sample-symbols '(A D A B B C A))
+(define sample-symbols-2 '(E C B A B E E A B B A A C A))
+
+;; (test-case (decode sample-message sample-tree) sample-symbols)
+;; (test-case (encode (decode sample-message sample-tree) sample-tree) sample-message)
+;; ;; (test-case (encode sample-symbols '()) "error: empty tree")
+;; ;; (test-case (encode sample-symbols sample-tree-2) "error: symbol not in tree")
+;; (test-case (encode sample-symbols-2 sample-tree-2) sample-message-2)
+;; (test-case (decode (encode sample-symbols-2 sample-tree-2) sample-tree-2) sample-symbols-2)
+
+;; Exercise 2.69. The following procedure takes as its argument a list of symbol-frequency pairs (where no symbol appears in more than one pair) and generates a Huffman encoding tree according to the Huffman algorithm.
+
+(define (generate-huffman-tree pairs)
+ (successive-merge (make-leaf-set pairs)))
+
+;; Make-leaf-set is the procedure given above that transforms the list of pairs into an ordered set of leaves. Successive-merge is the procedure you must write, using make-code-tree to successively merge the smallest-weight elements of the set until there is only one element left, which is the desired Huffman tree. (This procedure is slightly tricky, but not really complicated. If you find yourself designing a complex procedure, then you are almost certainly doing something wrong. You can take significant advantage of the fact that we are using an ordered set representation.)
+
+(define (successive-merge leaf-set)
+ (cond ((null? leaf-set) (error "no leaves in leaf-set"))
+ ((null? (cdr leaf-set)) (car leaf-set))
+ (else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set)
+ (car leaf-set))
+ (cddr leaf-set))))))
+
+
+;; (test-case (generate-huffman-tree '()) "no leaves in leaf-set")
+(test-case (generate-huffman-tree '((A 8))) '(leaf A 8))
+(test-case (generate-huffman-tree '((A 8) (B 3))) '((leaf A 8) (leaf B 3) (A B) 11)) ;; we'll put the element that appears later in the set of leaves on the left side of the tree by default
+(test-case (generate-huffman-tree '((A 8) (B 3) (C 1) (D 1) (E 1) (F 1) (G 1) (H 1)))
+ '((((leaf B 3)
+ ((leaf C 1) (leaf D 1) (C D) 2)
+ (B C D)
+ 5)
+ (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
+ (B C D E F G H)
+ 9)
+ (leaf A 8)
+ (B C D E F G H A)
+ 17))
+
+;; ((leaf H 1) (leaf G 1) (leaf F 1) (leaf E 1) (leaf D 1) (leaf C 1) (leaf B 3) (leaf A 8))
+;; ((leaf F 1) (leaf E 1) (leaf D 1) (leaf C 1) ((leaf G 1) (leaf H 1) (G H) 2) (leaf B 3) (leaf A 8))
+;; ((leaf D 1) (leaf C 1) ((leaf G 1) (leaf H 1) (G H) 2) ((leaf E 1) (leaf F 1) (E F) 2) (leaf B 3) (leaf A 8))
+;; (((leaf G 1) (leaf H 1) (G H) 2) ((leaf E 1) (leaf F 1) (E F) 2) ((leaf C 1) (leaf D 1) (C D) 2) (leaf B 3) (leaf A 8))
+;; (((leaf C 1) (leaf D 1) (C D) 2)
+;; (leaf B 3)
+;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
+;; (leaf A 8))
+;; ((((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
+;; ((leaf B 3)
+;; ((leaf C 1) (leaf D 1) (C D) 2)
+;; (B C D)
+;; 5)
+;; (leaf A 8))
+;; ((leaf A 8)
+;; (((leaf B 3)
+;; ((leaf C 1) (leaf D 1) (C D) 2)
+;; (B C D)
+;; 5)
+;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
+;; (B C D E F G H)
+;; 9))
+;; (((((leaf B 3)
+;; ((leaf C 1) (leaf D 1) (C D) 2)
+;; (B C D)
+;; 5)
+;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
+;; (B C D E F G H)
+;; 9)
+;; (leaf A 8)
+;; (B C D E F G H A)
+;; 17))
+;; ((((leaf B 3)
+;; ((leaf C 1) (leaf D 1) (C D) 2)
+;; (B C D)
+;; 5)
+;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
+;; (B C D E F G H)
+;; 9)
+;; (leaf A 8)
+;; (B C D E F G H A)
+;; 17)
blob - /dev/null
blob + 7fc3e34bc39bc6f0b6f645a0342f2339f581d147 (mode 644)
--- /dev/null
+++ ex2-69.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-leaf symbol weight)
+ (list 'leaf symbol weight))
+(define (leaf? object)
+ (eq? (car object) 'leaf))
+(define (symbol-leaf x) (cadr x))
+(define (weight-leaf x) (caddr x))
+
+(define (make-code-tree left right)
+ (list left
+ right
+ (append (symbols left) (symbols right))
+ (+ (weight left) (weight right))))
+
+(define (left-branch tree) (car tree))
+(define (right-branch tree) (cadr tree))
+(define (symbols tree)
+ (if (leaf? tree)
+ (list (symbol-leaf tree))
+ (caddr tree)))
+(define (weight tree)
+ (if (leaf? tree)
+ (weight-leaf tree)
+ (cadddr tree)))
+
+(define (decode bits tree)
+ (define (decode-1 bits current-branch)
+ (if (null? bits)
+ '()
+ (let ((next-branch
+ (choose-branch (car bits) current-branch)))
+ (if (leaf? next-branch)
+ (cons (symbol-leaf next-branch)
+ (decode-1 (cdr bits) tree))
+ (decode-1 (cdr bits) next-branch)))))
+ (decode-1 bits tree))
+(define (choose-branch bit branch)
+ (cond ((= bit 0) (left-branch branch))
+ ((= bit 1) (right-branch branch))
+ (else (error "bad bit -- CHOOSE-BRANCH" bit))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((< (weight x) (weight (car set))) (cons x set))
+ (else (cons (car set)
+ (adjoin-set x (cdr set))))))
+(define (make-leaf-set pairs)
+ (if (null? pairs)
+ '()
+ (let ((pair (car pairs)))
+ (adjoin-set (make-leaf (car pair)
+ (cadr pair))
+ (make-leaf-set (cdr pairs))))))
+
+;; Exercise 2.68. The encode procedure takes as arguments a message and a tree and produces the list of bits that gives the encoded message.
+
+(define (encode message tree)
+ (if (null? message)
+ '()
+ (append (encode-symbol (car message) tree)
+ (encode (cdr message) tree))))
+
+(define (element-of-set x set)
+ (and (not (null? set))
+ (or (equal? x (car set))
+ (element-of-set x (cdr set)))))
+
+;; (test-case (element-of-set 'A '()) #f)
+;; (test-case (element-of-set 'A '(1 B C D)) #f)
+;; (test-case (element-of-set 'A '(1 A B C)) #t)
+
+(define (encode-symbol sym tree)
+ (cond ((null? tree) (error "empty tree"))
+ ((not (element-of-set sym (symbols tree)))
+ (error "symbol not in tree"))
+ ((leaf? tree) '())
+ ((element-of-set sym (symbols (left-branch tree)))
+ (cons 0 (encode-symbol sym (left-branch tree))))
+ ((element-of-set sym (symbols (right-branch tree)))
+ (cons 1 (encode-symbol sym (right-branch tree))))))
+
+;; (define (encode-symbol sym tree)
+;; (cond ((null? tree) (error "empty tree"))
+;; ((leaf? tree) '())
+;; ((element-of-set sym (symbols (left-branch tree)))
+;; (cons 0 (encode-symbol sym (left-branch tree))))
+;; ((element-of-set sym (symbols (right-branch tree)))
+;; (cons 1 (encode-symbol sym (right-branch tree))))
+;; (else (error "symbol not in tree")))))
+
+;; Encode-symbol is a procedure, which you must write, that returns the list of bits that encodes a given symbol according to a given tree. You should design encode-symbol so that it signals an error if the symbol is not in the tree at all. Test your procedure by encoding the result you obtained in exercise 2.67 with the sample tree and seeing whether it is the same as the original sample message.
+
+(define sample-tree
+ (make-code-tree (make-leaf 'A 4)
+ (make-code-tree
+ (make-leaf 'B 2)
+ (make-code-tree (make-leaf 'D 1)
+ (make-leaf 'C 1)))))
+(define sample-tree-2
+ (make-code-tree (make-leaf 'A 4)
+ (make-code-tree
+ (make-leaf 'B 2)
+ (make-code-tree (make-leaf 'E 1)
+ (make-leaf 'C 1)))))
+
+(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
+(define sample-message-2 '(1 1 0 1 1 1 1 0 0 1 0 1 1 0 1 1 0 0 1 0 1 0 0 0 1 1 1 0))
+(define sample-symbols '(A D A B B C A))
+(define sample-symbols-2 '(E C B A B E E A B B A A C A))
+(test-case (decode sample-message sample-tree) sample-symbols)
+
+(test-case (encode (decode sample-message sample-tree) sample-tree) sample-message)
+;; (test-case (encode sample-symbols '()) "error: empty tree")
+;; (test-case (encode sample-symbols sample-tree-2) "error: symbol not in tree")
+(test-case (encode sample-symbols-2 sample-tree-2) sample-message-2)
+(test-case (decode (encode sample-symbols-2 sample-tree-2) sample-tree-2) sample-symbols-2)
+
+;; Exercise 2.69. The following procedure takes as its argument a list of symbol-frequency pairs (where no symbol appears in more than one pair) and generates a Huffman encoding tree according to the Huffman algorithm.
+
+(define (generate-huffman-tree pairs)
+ (successive-merge (make-leaf-set pairs)))
+
+;; Make-leaf-set is the procedure given above that transforms the list of pairs into an ordered set of leaves. Successive-merge is the procedure you must write, using make-code-tree to successively merge the smallest-weight elements of the set until there is only one element left, which is the desired Huffman tree. (This procedure is slightly tricky, but not really complicated. If you find yourself designing a complex procedure, then you are almost certainly doing something wrong. You can take significant advantage of the fact that we are using an ordered set representation.)
blob - /dev/null
blob + 55f82533de4af68dba5fb302180c789ae30ca9d8 (mode 644)
--- /dev/null
+++ ex2-7.scm
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+(define (mul-interval x y)
+ (let ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (div-interval x y)
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))
+
+(define (make-interval a b)
+ (cons a b))
+(define (upper-bound x)
+ (cdr x))
+(define (lower-bound x)
+ (car x))
+
+
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + d6198b67d62944a5e5434ab08cc57064aec77cea (mode 644)
--- /dev/null
+++ ex2-70.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-leaf symbol weight)
+ (list 'leaf symbol weight))
+(define (leaf? object)
+ (eq? (car object) 'leaf))
+(define (symbol-leaf x) (cadr x))
+(define (weight-leaf x) (caddr x))
+
+(define (make-code-tree left right)
+ (list left
+ right
+ (append (symbols left) (symbols right))
+ (+ (weight left) (weight right))))
+
+(define (left-branch tree) (car tree))
+(define (right-branch tree) (cadr tree))
+(define (symbols tree)
+ (if (leaf? tree)
+ (list (symbol-leaf tree))
+ (caddr tree)))
+(define (weight tree)
+ (if (leaf? tree)
+ (weight-leaf tree)
+ (cadddr tree)))
+
+(define (decode bits tree)
+ (define (decode-1 bits current-branch)
+ (if (null? bits)
+ '()
+ (let ((next-branch
+ (choose-branch (car bits) current-branch)))
+ (if (leaf? next-branch)
+ (cons (symbol-leaf next-branch)
+ (decode-1 (cdr bits) tree))
+ (decode-1 (cdr bits) next-branch)))))
+ (decode-1 bits tree))
+(define (choose-branch bit branch)
+ (cond ((= bit 0) (left-branch branch))
+ ((= bit 1) (right-branch branch))
+ (else (error "bad bit -- CHOOSE-BRANCH" bit))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((< (weight x) (weight (car set))) (cons x set))
+ (else (cons (car set)
+ (adjoin-set x (cdr set))))))
+(define (make-leaf-set pairs)
+ (if (null? pairs)
+ '()
+ (let ((pair (car pairs)))
+ (adjoin-set (make-leaf (car pair)
+ (cadr pair))
+ (make-leaf-set (cdr pairs))))))
+
+(define (encode message tree)
+ (if (null? message)
+ '()
+ (append (encode-symbol (car message) tree)
+ (encode (cdr message) tree))))
+
+(define (element-of-set x set)
+ (and (not (null? set))
+ (or (equal? x (car set))
+ (element-of-set x (cdr set)))))
+
+(define (encode-symbol sym tree)
+ (cond ((null? tree) (error "empty tree"))
+ ((not (element-of-set sym (symbols tree)))
+ (error "symbol not in tree"))
+ ((leaf? tree) '())
+ ((element-of-set sym (symbols (left-branch tree)))
+ (cons 0 (encode-symbol sym (left-branch tree))))
+ ((element-of-set sym (symbols (right-branch tree)))
+ (cons 1 (encode-symbol sym (right-branch tree))))))
+
+(define (generate-huffman-tree pairs)
+ (successive-merge (make-leaf-set pairs)))
+
+(define (successive-merge leaf-set)
+ (cond ((null? leaf-set) (error "no leaves in leaf-set"))
+ ((null? (cdr leaf-set)) (car leaf-set))
+ (else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set)
+ (car leaf-set))
+ (cddr leaf-set))))))
+
+;; Exercise 2.70. The following eight-symbol alphabet with associated relative frequencies was designed to efficiently encode the lyrics of 1950s rock songs. (Note that the ``symbols'' of an ``alphabet'' need not be individual letters.)
+
+;; A 2 NA 16
+;; BOOM 1 SHA 3
+;; GET 2 YIP 9
+;; JOB 2 WAH 1
+;; Use generate-huffman-tree (exercise 2.69) to generate a corresponding Huffman tree, and use encode (exercise 2.68) to encode the following message:
+
+(test-case (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1)))
+ '((((((leaf get 2) (leaf job 2) (get job) 4)
+ (leaf sha 3)
+ (get job sha)
+ 7)
+ (((leaf boom 1) (leaf wah 1) (boom wah) 2)
+ (leaf a 2)
+ (boom wah a)
+ 4)
+ (get job sha boom wah a)
+ 11)
+ (leaf yip 9)
+ (get job sha boom wah a yip)
+ 20)
+ (leaf na 16)
+ (get job sha boom wah a yip na)
+ 36))
+(test-case (encode '(get a job sha na na na na na na na na get a job sha na na na na na na na na wah yip yip yip yip yip yip yip yip yip sha boom)
+ (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1))))
+ '(0 0 0 0 0 0 0 1 1 0 0 0 0 1 0 0 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 1 1 0 0 0 0 1 0 0 0 1 1 1 1 1 1 1 1 1 0 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 0 0 1 0 0 1 0 0))
+
+;; GET 00000
+;; JOB 00001
+;; SHA 0001
+;; BOOM 00100
+;; WAH 00101
+;; A 0011
+;; YIP 01
+;; NA 1
+
+;; Get a job
+
+;; Sha na na na na na na na na
+
+;; Get a job
+
+;; Sha na na na na na na na na
+
+;; Wah yip yip yip yip yip yip yip yip yip
+
+;; Sha boom
+
+;; How many bits are required for the encoding? What is the smallest number of bits that would be needed to encode this song if we used a fixed-length code for the eight-symbol alphabet?
+
+;; 5 bits are required at most for encoding a symbol, which is actually 2 bits more than fixed-length code
+
+;; Overall, though, only 84 bits are required using Huffman encoding vs. 108 bits for fixed-length code
blob - /dev/null
blob + 179fc78f1abdb3aed52fc45f412afdf863975fff (mode 644)
--- /dev/null
+++ ex2-70.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-leaf symbol weight)
+ (list 'leaf symbol weight))
+(define (leaf? object)
+ (eq? (car object) 'leaf))
+(define (symbol-leaf x) (cadr x))
+(define (weight-leaf x) (caddr x))
+
+(define (make-code-tree left right)
+ (list left
+ right
+ (append (symbols left) (symbols right))
+ (+ (weight left) (weight right))))
+
+(define (left-branch tree) (car tree))
+(define (right-branch tree) (cadr tree))
+(define (symbols tree)
+ (if (leaf? tree)
+ (list (symbol-leaf tree))
+ (caddr tree)))
+(define (weight tree)
+ (if (leaf? tree)
+ (weight-leaf tree)
+ (cadddr tree)))
+
+(define (decode bits tree)
+ (define (decode-1 bits current-branch)
+ (if (null? bits)
+ '()
+ (let ((next-branch
+ (choose-branch (car bits) current-branch)))
+ (if (leaf? next-branch)
+ (cons (symbol-leaf next-branch)
+ (decode-1 (cdr bits) tree))
+ (decode-1 (cdr bits) next-branch)))))
+ (decode-1 bits tree))
+(define (choose-branch bit branch)
+ (cond ((= bit 0) (left-branch branch))
+ ((= bit 1) (right-branch branch))
+ (else (error "bad bit -- CHOOSE-BRANCH" bit))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((< (weight x) (weight (car set))) (cons x set))
+ (else (cons (car set)
+ (adjoin-set x (cdr set))))))
+(define (make-leaf-set pairs)
+ (if (null? pairs)
+ '()
+ (let ((pair (car pairs)))
+ (adjoin-set (make-leaf (car pair)
+ (cadr pair))
+ (make-leaf-set (cdr pairs))))))
+
+(define (encode message tree)
+ (if (null? message)
+ '()
+ (append (encode-symbol (car message) tree)
+ (encode (cdr message) tree))))
+
+(define (element-of-set x set)
+ (and (not (null? set))
+ (or (equal? x (car set))
+ (element-of-set x (cdr set)))))
+
+(define (encode-symbol sym tree)
+ (cond ((null? tree) (error "empty tree"))
+ ((not (element-of-set sym (symbols tree)))
+ (error "symbol not in tree"))
+ ((leaf? tree) '())
+ ((element-of-set sym (symbols (left-branch tree)))
+ (cons 0 (encode-symbol sym (left-branch tree))))
+ ((element-of-set sym (symbols (right-branch tree)))
+ (cons 1 (encode-symbol sym (right-branch tree))))))
+
+(define sample-tree
+ (make-code-tree (make-leaf 'A 4)
+ (make-code-tree
+ (make-leaf 'B 2)
+ (make-code-tree (make-leaf 'D 1)
+ (make-leaf 'C 1)))))
+(define sample-tree-2
+ (make-code-tree (make-leaf 'A 4)
+ (make-code-tree
+ (make-leaf 'B 2)
+ (make-code-tree (make-leaf 'E 1)
+ (make-leaf 'C 1)))))
+
+(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
+(define sample-message-2 '(1 1 0 1 1 1 1 0 0 1 0 1 1 0 1 1 0 0 1 0 1 0 0 0 1 1 1 0))
+(define sample-symbols '(A D A B B C A))
+(define sample-symbols-2 '(E C B A B E E A B B A A C A))
+
+;; (test-case (decode sample-message sample-tree) sample-symbols)
+;; (test-case (encode (decode sample-message sample-tree) sample-tree) sample-message)
+;; ;; (test-case (encode sample-symbols '()) "error: empty tree")
+;; ;; (test-case (encode sample-symbols sample-tree-2) "error: symbol not in tree")
+;; (test-case (encode sample-symbols-2 sample-tree-2) sample-message-2)
+;; (test-case (decode (encode sample-symbols-2 sample-tree-2) sample-tree-2) sample-symbols-2)
+
+;; Exercise 2.69. The following procedure takes as its argument a list of symbol-frequency pairs (where no symbol appears in more than one pair) and generates a Huffman encoding tree according to the Huffman algorithm.
+
+(define (generate-huffman-tree pairs)
+ (successive-merge (make-leaf-set pairs)))
+
+;; Make-leaf-set is the procedure given above that transforms the list of pairs into an ordered set of leaves. Successive-merge is the procedure you must write, using make-code-tree to successively merge the smallest-weight elements of the set until there is only one element left, which is the desired Huffman tree. (This procedure is slightly tricky, but not really complicated. If you find yourself designing a complex procedure, then you are almost certainly doing something wrong. You can take significant advantage of the fact that we are using an ordered set representation.)
+
+(define (successive-merge leaf-set)
+ (cond ((null? leaf-set) (error "no leaves in leaf-set"))
+ ((null? (cdr leaf-set)) (car leaf-set))
+ (else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set)
+ (car leaf-set))
+ (cddr leaf-set))))))
+
+
+;; (test-case (generate-huffman-tree '()) "no leaves in leaf-set")
+(test-case (generate-huffman-tree '((A 8))) '(leaf A 8))
+(test-case (generate-huffman-tree '((A 8) (B 3))) '((leaf A 8) (leaf B 3) (A B) 11)) ;; we'll put the element that appears later in the set of leaves on the left side of the tree by default
+(test-case (generate-huffman-tree '((A 8) (B 3) (C 1) (D 1) (E 1) (F 1) (G 1) (H 1)))
+ '((((leaf B 3)
+ ((leaf C 1) (leaf D 1) (C D) 2)
+ (B C D)
+ 5)
+ (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
+ (B C D E F G H)
+ 9)
+ (leaf A 8)
+ (B C D E F G H A)
+ 17))
+
+;; ((leaf H 1) (leaf G 1) (leaf F 1) (leaf E 1) (leaf D 1) (leaf C 1) (leaf B 3) (leaf A 8))
+;; ((leaf F 1) (leaf E 1) (leaf D 1) (leaf C 1) ((leaf G 1) (leaf H 1) (G H) 2) (leaf B 3) (leaf A 8))
+;; ((leaf D 1) (leaf C 1) ((leaf G 1) (leaf H 1) (G H) 2) ((leaf E 1) (leaf F 1) (E F) 2) (leaf B 3) (leaf A 8))
+;; (((leaf G 1) (leaf H 1) (G H) 2) ((leaf E 1) (leaf F 1) (E F) 2) ((leaf C 1) (leaf D 1) (C D) 2) (leaf B 3) (leaf A 8))
+;; (((leaf C 1) (leaf D 1) (C D) 2)
+;; (leaf B 3)
+;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
+;; (leaf A 8))
+;; ((((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
+;; ((leaf B 3)
+;; ((leaf C 1) (leaf D 1) (C D) 2)
+;; (B C D)
+;; 5)
+;; (leaf A 8))
+;; ((leaf A 8)
+;; (((leaf B 3)
+;; ((leaf C 1) (leaf D 1) (C D) 2)
+;; (B C D)
+;; 5)
+;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
+;; (B C D E F G H)
+;; 9))
+;; (((((leaf B 3)
+;; ((leaf C 1) (leaf D 1) (C D) 2)
+;; (B C D)
+;; 5)
+;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
+;; (B C D E F G H)
+;; 9)
+;; (leaf A 8)
+;; (B C D E F G H A)
+;; 17))
+;; ((((leaf B 3)
+;; ((leaf C 1) (leaf D 1) (C D) 2)
+;; (B C D)
+;; 5)
+;; (((leaf E 1) (leaf F 1) (E F) 2) ((leaf G 1) (leaf H 1) (G H) 2) (E F G H) 4)
+;; (B C D E F G H)
+;; 9)
+;; (leaf A 8)
+;; (B C D E F G H A)
+;; 17)
blob - /dev/null
blob + 517a3563a76b63ceb91a3e35e2f83ab912854df8 (mode 644)
Binary files /dev/null and ex2-70.xcf differ
blob - /dev/null
blob + 58310bd1611ab3c2b8080f13bc330fbacc94fb1f (mode 644)
--- /dev/null
+++ ex2-71.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-leaf symbol weight)
+ (list 'leaf symbol weight))
+(define (leaf? object)
+ (eq? (car object) 'leaf))
+(define (symbol-leaf x) (cadr x))
+(define (weight-leaf x) (caddr x))
+
+(define (make-code-tree left right)
+ (list left
+ right
+ (append (symbols left) (symbols right))
+ (+ (weight left) (weight right))))
+
+(define (left-branch tree) (car tree))
+(define (right-branch tree) (cadr tree))
+(define (symbols tree)
+ (if (leaf? tree)
+ (list (symbol-leaf tree))
+ (caddr tree)))
+(define (weight tree)
+ (if (leaf? tree)
+ (weight-leaf tree)
+ (cadddr tree)))
+
+(define (decode bits tree)
+ (define (decode-1 bits current-branch)
+ (if (null? bits)
+ '()
+ (let ((next-branch
+ (choose-branch (car bits) current-branch)))
+ (if (leaf? next-branch)
+ (cons (symbol-leaf next-branch)
+ (decode-1 (cdr bits) tree))
+ (decode-1 (cdr bits) next-branch)))))
+ (decode-1 bits tree))
+(define (choose-branch bit branch)
+ (cond ((= bit 0) (left-branch branch))
+ ((= bit 1) (right-branch branch))
+ (else (error "bad bit -- CHOOSE-BRANCH" bit))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((< (weight x) (weight (car set))) (cons x set))
+ (else (cons (car set)
+ (adjoin-set x (cdr set))))))
+(define (make-leaf-set pairs)
+ (if (null? pairs)
+ '()
+ (let ((pair (car pairs)))
+ (adjoin-set (make-leaf (car pair)
+ (cadr pair))
+ (make-leaf-set (cdr pairs))))))
+
+(define (encode message tree)
+ (if (null? message)
+ '()
+ (append (encode-symbol (car message) tree)
+ (encode (cdr message) tree))))
+
+(define (element-of-set x set)
+ (and (not (null? set))
+ (or (equal? x (car set))
+ (element-of-set x (cdr set)))))
+
+(define (encode-symbol sym tree)
+ (cond ((null? tree) (error "empty tree"))
+ ((not (element-of-set sym (symbols tree)))
+ (error "symbol not in tree"))
+ ((leaf? tree) '())
+ ((element-of-set sym (symbols (left-branch tree)))
+ (cons 0 (encode-symbol sym (left-branch tree))))
+ ((element-of-set sym (symbols (right-branch tree)))
+ (cons 1 (encode-symbol sym (right-branch tree))))))
+
+(define (generate-huffman-tree pairs)
+ (successive-merge (make-leaf-set pairs)))
+
+(define (successive-merge leaf-set)
+ (cond ((null? leaf-set) (error "no leaves in leaf-set"))
+ ((null? (cdr leaf-set)) (car leaf-set))
+ (else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set)
+ (car leaf-set))
+ (cddr leaf-set))))))
+
+;; Exercise 2.71. Suppose we have a Huffman tree for an alphabet of n symbols, and that the relative frequencies of the symbols are 1, 2, 4, ..., 2^n-1. Sketch the tree for n=5; for n=10. In such a tree (for general n) how many bits are required to encode the most frequent symbol? the least frequent symbol?
+
+;; for a tree of n symbols, 1 bit for most frequent; n-1 bits for least frequent symbol
+
+;; Exercise 2.72. Consider the encoding procedure that you designed in exercise 2.68. What is the order of growth in the number of steps needed to encode a symbol? Be sure to include the number of steps needed to search the symbol list at each node encountered. To answer this question in general is difficult. Consider the special case where the relative frequencies of the n symbols are as described in exercise 2.71, and give the order of growth (as a function of n) of the number of steps needed to encode the most frequent and least frequent symbols in the alphabet.
+
+(define (encode message tree)
+ (if (null? message)
+ '()
+ (append (encode-symbol (car message) tree)
+ (encode (cdr message) tree))))
+
+(define (element-of-set x set)
+ (and (not (null? set))
+ (or (equal? x (car set))
+ (element-of-set x (cdr set)))))
+
+(define (encode-symbol sym tree)
+ (cond ((null? tree) (error "empty tree"))
+;; we're going to pretend this isn't here to speed up the procedure
+;; ((not (element-of-set sym (symbols tree)))
+;; (error "symbol not in tree"))
+ ((leaf? tree) '())
+ ((element-of-set sym (symbols (left-branch tree)))
+ (cons 0 (encode-symbol sym (left-branch tree))))
+ ((element-of-set sym (symbols (right-branch tree)))
+ (cons 1 (encode-symbol sym (right-branch tree))))))
+
+we must call encode-symbol the same number of times as the length of message
+So, if message is m elements long, we must call encode-symbol m times
+
+Within encode-symbol, we must check through the list of symbols either on the left-branch or on the right-branch. If the symbol is on the left-branch, we just check 1 element. Otherwise, we must check, on average, (n-1)/2 elements. There is roughly a 50-50 chance that the symbol will be on the left-branch vs. right-branch.
+
+50%: 1
+25%: (n-1)/2 + 1
+12.5%: (n-1)/2 + (n-2)/2 + 1
+6.25%: ...
+
+Most frequent symbols O(1), but least-frequent symbol is O(n^2)
blob - /dev/null
blob + d6198b67d62944a5e5434ab08cc57064aec77cea (mode 644)
--- /dev/null
+++ ex2-71.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-leaf symbol weight)
+ (list 'leaf symbol weight))
+(define (leaf? object)
+ (eq? (car object) 'leaf))
+(define (symbol-leaf x) (cadr x))
+(define (weight-leaf x) (caddr x))
+
+(define (make-code-tree left right)
+ (list left
+ right
+ (append (symbols left) (symbols right))
+ (+ (weight left) (weight right))))
+
+(define (left-branch tree) (car tree))
+(define (right-branch tree) (cadr tree))
+(define (symbols tree)
+ (if (leaf? tree)
+ (list (symbol-leaf tree))
+ (caddr tree)))
+(define (weight tree)
+ (if (leaf? tree)
+ (weight-leaf tree)
+ (cadddr tree)))
+
+(define (decode bits tree)
+ (define (decode-1 bits current-branch)
+ (if (null? bits)
+ '()
+ (let ((next-branch
+ (choose-branch (car bits) current-branch)))
+ (if (leaf? next-branch)
+ (cons (symbol-leaf next-branch)
+ (decode-1 (cdr bits) tree))
+ (decode-1 (cdr bits) next-branch)))))
+ (decode-1 bits tree))
+(define (choose-branch bit branch)
+ (cond ((= bit 0) (left-branch branch))
+ ((= bit 1) (right-branch branch))
+ (else (error "bad bit -- CHOOSE-BRANCH" bit))))
+
+(define (adjoin-set x set)
+ (cond ((null? set) (list x))
+ ((< (weight x) (weight (car set))) (cons x set))
+ (else (cons (car set)
+ (adjoin-set x (cdr set))))))
+(define (make-leaf-set pairs)
+ (if (null? pairs)
+ '()
+ (let ((pair (car pairs)))
+ (adjoin-set (make-leaf (car pair)
+ (cadr pair))
+ (make-leaf-set (cdr pairs))))))
+
+(define (encode message tree)
+ (if (null? message)
+ '()
+ (append (encode-symbol (car message) tree)
+ (encode (cdr message) tree))))
+
+(define (element-of-set x set)
+ (and (not (null? set))
+ (or (equal? x (car set))
+ (element-of-set x (cdr set)))))
+
+(define (encode-symbol sym tree)
+ (cond ((null? tree) (error "empty tree"))
+ ((not (element-of-set sym (symbols tree)))
+ (error "symbol not in tree"))
+ ((leaf? tree) '())
+ ((element-of-set sym (symbols (left-branch tree)))
+ (cons 0 (encode-symbol sym (left-branch tree))))
+ ((element-of-set sym (symbols (right-branch tree)))
+ (cons 1 (encode-symbol sym (right-branch tree))))))
+
+(define (generate-huffman-tree pairs)
+ (successive-merge (make-leaf-set pairs)))
+
+(define (successive-merge leaf-set)
+ (cond ((null? leaf-set) (error "no leaves in leaf-set"))
+ ((null? (cdr leaf-set)) (car leaf-set))
+ (else (successive-merge (adjoin-set (make-code-tree (cadr leaf-set)
+ (car leaf-set))
+ (cddr leaf-set))))))
+
+;; Exercise 2.70. The following eight-symbol alphabet with associated relative frequencies was designed to efficiently encode the lyrics of 1950s rock songs. (Note that the ``symbols'' of an ``alphabet'' need not be individual letters.)
+
+;; A 2 NA 16
+;; BOOM 1 SHA 3
+;; GET 2 YIP 9
+;; JOB 2 WAH 1
+;; Use generate-huffman-tree (exercise 2.69) to generate a corresponding Huffman tree, and use encode (exercise 2.68) to encode the following message:
+
+(test-case (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1)))
+ '((((((leaf get 2) (leaf job 2) (get job) 4)
+ (leaf sha 3)
+ (get job sha)
+ 7)
+ (((leaf boom 1) (leaf wah 1) (boom wah) 2)
+ (leaf a 2)
+ (boom wah a)
+ 4)
+ (get job sha boom wah a)
+ 11)
+ (leaf yip 9)
+ (get job sha boom wah a yip)
+ 20)
+ (leaf na 16)
+ (get job sha boom wah a yip na)
+ 36))
+(test-case (encode '(get a job sha na na na na na na na na get a job sha na na na na na na na na wah yip yip yip yip yip yip yip yip yip sha boom)
+ (generate-huffman-tree '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1))))
+ '(0 0 0 0 0 0 0 1 1 0 0 0 0 1 0 0 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 1 1 0 0 0 0 1 0 0 0 1 1 1 1 1 1 1 1 1 0 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 0 0 1 0 0 1 0 0))
+
+;; GET 00000
+;; JOB 00001
+;; SHA 0001
+;; BOOM 00100
+;; WAH 00101
+;; A 0011
+;; YIP 01
+;; NA 1
+
+;; Get a job
+
+;; Sha na na na na na na na na
+
+;; Get a job
+
+;; Sha na na na na na na na na
+
+;; Wah yip yip yip yip yip yip yip yip yip
+
+;; Sha boom
+
+;; How many bits are required for the encoding? What is the smallest number of bits that would be needed to encode this song if we used a fixed-length code for the eight-symbol alphabet?
+
+;; 5 bits are required at most for encoding a symbol, which is actually 2 bits more than fixed-length code
+
+;; Overall, though, only 84 bits are required using Huffman encoding vs. 108 bits for fixed-length code
blob - /dev/null
blob + e16d18f7ae8ac32627e2060a190d82fcb92d5938 (mode 644)
Binary files /dev/null and ex2-71.xcf differ
blob - /dev/null
blob + 773308096879f19fc97fe1dca85048e7a77f8467 (mode 644)
--- /dev/null
+++ ex2-73-sol-2.scm
+(define *op-table* (make-has-table 'equal))
+(define (put op type proc)
+ (hash-table-put! *op-table* (list op type) proc))
+(define (get op type)
+ (hash-table-get *op-table* (list op type) '()))
+
+(define (install-deriv-package)
+ (define (make-sum a1 a2) (list '+ a1 a2))
+ (define (addend s) (car s))
+ (define (augend s) (cadr s))
+ (define (make-product m1 m2) (list '* m1 m2))
+ (define (multiplier p) (car p))
+ (define (multiplicand p) (cadr p))
+ (define (deriv-sum exp var)
+ (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ (define (deriv-product exp var)
+ (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (define (make-exponentiation base exp)
+ (list '** base exp))
+ (define (base s) (car s))
+ (define (exponent s) (cadr s))
+ (define (deriv-exponentiation exp var)
+ (make-product
+ (make-product
+ (exponent exp)
+ (make-exponentiation
+ (base exp)
+ (- (exponent exp) 1)))
+ (deriv (base exp) var)))
+ (put 'deriv '** deriv-exponentiation)
+ (put 'deriv '+ deriv-sum)
+ (put 'deriv '* deriv-product))
+
blob - /dev/null
blob + a47af84e01db32d502eae178483fd19f1ff8f14d (mode 644)
--- /dev/null
+++ ex2-73-sol-2.scm~
+(define *op-table* (make-has-table 'equal))
+(define (put op type proc)
+ (hash-table-put! *op-table* (list op type) proc))
+(define (get op type)
+ (hash-table-get *op-table* (list op type) '()))
blob - /dev/null
blob + 324b43b4083e918382c907e48fec4bd8e4bbf50e (mode 644)
--- /dev/null
+++ ex2-73-sol.scm
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp)
+ (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp)
+ (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (else (error "unknown expression type -- DERIV" exp))))
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ (else ((get 'deriv (operator exp)) (operands exp) var))))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+
+#lang racket
+(require rnrs/base-6)
+(require rnrs/mutable-pairs-6)
+
+(define (assoc key records)
+ (cond ((null? records) #f)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+(define (make-table)
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ #f))
+ #f)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (deriv exp var)
+ ((get 'deriv (operator exp)) (operands exp) var))
+(define (operator exp)
+ (cond ((number? exp) 'number)
+ ((variable? exp) 'variable)
+ (else (car exp))))
+(define (operands exp)
+ (if (pair? exp)
+ (cdr exp)
+ (list exp)))
+(define (install-number-routines)
+ (define (derivative ops var) 0)
+ (put 'deriv 'number derivative))
+(define (install-variable-routines)
+ (define (derivative ops var)
+ (if (same-variable? (car ops) var) 1 0))
+ (put 'deriv 'variable derivative))
+(install-number-routines)
+(install-variable-routines)
+
+(define (install-sum-routines)
+ (define (derivative ops var)
+ (make-sum
+ (deriv (car ops) var)
+ (deriv (cadr ops) var)))
+ (put 'deriv '+ derivative))
+(define (install-product-routines)
+ (define (derivative ops var)
+ (make-sum
+ (make-product (car ops)
+ (deriv (cadr ops) var))
+ (make-product (deriv (car ops) var)
+ (cadr ops))))
+ (put 'deriv '* derivative))
+(install-sum-routines)
+(install-product-routines)
+
+((exponentiation? exp)
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+ (deriv (base exp) var)))
+
+(define (install-exponent-routines)
+ (define (derivative ops var)
+ (make-product
+ (make-product (cadr ops)
+ (make-exponentiation (car ops)
+ (make-sum (cadr ops) -1)))
+ (deriv (car ops) var)))
+ (put 'deriv '** derivative))
+
+((get (operator exp) 'deriv) (operands exp) var)
+
+(define (install-derivative-routines)
+ (define (sum ops var)
+ (make-sum
+ (deriv (car ops) var)
+ (deriv (cadr ops) var)))
+ (define (product ops var)
+ (make-sum
+ (make-product (car ops)
+ (deriv (cadr ops) var))
+ (make-product (deriv (car ops) var)
+ (cadr ops))))
+ (define (exponent ops var)
+ (make-product
+ (make-product (cadr ops)
+ (make-exponentiation (car ops)
+ (make-sum (cadr ops) -1)))
+ (deriv (car ops) var)))
+ (put '+ 'deriv sum)
+ (put '* 'deriv product)
+ (put '** 'deriv exponent))
+
+
+;; weiquan
+
+(define (install-deriv-package)
+ (define (=number? exp num)
+ (and (number? exp) (= exp num)))
+(define (make-sum a1 a2)
+ (cond ((=number? a1 0) a2
blob - /dev/null
blob + e7d79045817d1238cdd7f267260af4bb9a4a7bae (mode 644)
--- /dev/null
+++ ex2-73-sol.scm~
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp)
+ (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp)
+ (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (else (error "unknown expression type -- DERIV" exp))))
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ (else ((get 'deriv (operator exp)) (operands exp) var))))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+
+#lang racket
+(require rnrs/base-6)
+(require rnrs/mutable-pairs-6)
+
+(define (assoc key records)
+ (cond ((null? records) #f)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+(define (make-table)
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ #f))
+ #f)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (deriv exp var)
+ ((get 'deriv (operator exp)) (operands exp) var))
+(define (operator exp)
+ (cond ((number? exp) 'number)
+ ((variable? exp) 'variable)
+ (else (car exp))))
+(define (operands exp)
+ (if (pair? exp)
+ (cdr exp)
+ (list exp)))
+(define (install-number-routines)
+ (define (derivative ops var) 0)
+ (put 'deriv 'number derivative))
+(define (install-variable-routines)
+ (define (derivative ops var)
+ (if (same-variable? (car ops) var) 1 0))
+ (put 'deriv 'variable derivative))
+(install-number-routines)
+(install-variable-routines)
+
+(define (install-sum-routines)
+ (define (derivative ops var)
+ (make-sum
+ (deriv (car ops) var)
+ (deriv (cadr ops) var)))
+ (put 'deriv '+ derivative))
+(define (install-product-routines)
+ (define (derivative ops var)
+ (make-sum
+ (make-product (car ops)
+ (deriv (cadr ops) var))
+ (make-product (deriv (car ops) var)
+ (cadr ops))))
+ (put 'deriv '* derivative))
+(install-sum-routines)
+(install-product-routines)
+
+((exponentiation? exp)
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+ (deriv (base exp) var)))
+
+(define (install-exponent-routines)
+ (define (derivative ops var)
+ (make-product
+ (make-product (cadr ops)
+ (make-exponentiation (car ops)
+ (make-sum (cadr ops) -1)))
+ (deriv (car ops) var)))
+ (put 'deriv '** derivative))
+
+((get (operator exp) 'deriv) (operands exp) var)
+
+(define (install-derivative-routines)
+ (define (sum ops var)
+ (make-sum
+ (deriv (car ops) var)
+ (deriv (cadr ops) var)))
+ (define (product ops var)
+ (make-sum
+ (make-product (car ops)
+ (deriv (cadr ops) var))
+ (make-product (deriv (car ops) var)
+ (cadr ops))))
+ (define (exponent ops var)
+ (make-product
+ (make-product (cadr ops)
+ (make-exponentiation (car ops)
+ (make-sum (cadr ops) -1)))
+ (deriv (car ops) var)))
+ (put '+ 'deriv sum)
+ (put '* 'deriv product)
+ (put '** 'deriv exponent))
+
blob - /dev/null
blob + 0406d9f0430c2e8b8bf2806fbc6bb76a2e9ea757 (mode 644)
--- /dev/null
+++ ex2-73.lisp~
+(define *op-table* (make-has-table 'equal))
+(define (put op type proc)
+ (hash-table-put! *op-table* (list op type) proc))
blob - /dev/null
blob + c0f93065dc48a7f9a5145bbb4260dfcad74556c9 (mode 644)
--- /dev/null
+++ ex2-73.scm
+(define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+(define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+(define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+(define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+
+(define (attach-tag type-tag contents)
+ (cons type-tag contents))
+(define (type-tag datum)
+ (if (pair? datum)
+ (car datum)
+ (error "Bad tagged datum -- TYPE-TAG" datum)))
+(define (contents datum)
+ (if (pair? datum)
+ (cdr datum)
+ (error "Bad tagged datum -- CONTENTS" datum)))
+(define (rectangular? z)
+ (eq? (type-tag z) 'rectangular))
+(define (polar? z)
+ (eq? (type-tag z) 'polar))
+
+(define (install-rectangular-package)
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (make-from-real-imag x y)
+ (cons x y))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z)
+ (atan (imag-part z) (real-part z)))
+ (define (make-from-mag-ang r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (install-polar-package)
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (make-from-mag-ang r a) (cons r a))
+ (define (real-part z)
+ (* (magnitude z) (cos (angle z))))
+ (define (imag-part z)
+ (* (magnitude z) (sin (angle z))))
+ (define (make-from-real-imag x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error
+ "No method for these types -- APPLY-GENERIC"
+ (list op type-tags)))))
+
+(define (real-part z) (apply-generic 'real-part z))
+(define (imag-part z) (apply-generic 'imag-part z))
+(define (magnitude z) (apply-generic 'magnitude z))
+(define (angle z) (apply-generic 'angle z))
+(define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+(define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+;; We can regard this program as performing a dispatch on the type of the expression to be differentiated. In this situation the ``type tag'' of the datum is the algebraic operator symbol (such as +) and the operation being performed is deriv. We can transform this program into data-directed style by rewriting the basic derivative procedure as
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ (else ((get 'deriv (operator exp)) (operands exp)
+ var))))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+
+;; a. Explain what was done above. Why can't we assimilate the predicates number? and same-variable? into the data-directed dispatch?
+
+;; If exp is a number, we return 0. If it is a variable and we are taking the derivative with respect the same variable, we return 1 (otherwise we return 0). Otherwise, we go to the operation-and-type table and look up the procedure with operation name 'deriv and data type with the same operator. We then apply this procedure on the operands of the expression (passed as a list) and the variable.
+
+;; We cannot assimilate the predicates because there are no operators for simple numbers and variables. These expressions are not lists.
+
+;; b. Write the procedures for derivatives of sums and products, and the auxiliary code required to install them in the table used by the program above.
+
+(define (first-operand operands)
+ (car operands))
+(define (rest-operands operands)
+ (cdr operands))
+(define (deriv-sum operands var)
+ (make-sum (deriv (first-operand operands) var)
+ (deriv (rest-operands operands) var)))
+(define (deriv-product operands var)
+ (make-sum
+ (make-product (first-operand operands)
+ (deriv (rest-operands operands) var))
+ (make-product (deriv (first-operand operands) var)
+ (rest-operands operands))))
+(put 'deriv '+ deriv-sum)
+(put 'deriv '* deriv-product)
+
+;; c. Choose any additional differentiation rule that you like, such as the one for exponents (exercise 2.56), and install it in this data-directed system.
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+(define (=number? x num)
+ (and (number? x) (= x num)))
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+
+(define (deriv-exp operands var)
+ (car operands) (cadr operands)...)
+
+(put 'deriv '** deriv-exp)
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+
+
+(define (deriv-exp)
+
+d. In this simple algebraic manipulator the type of an expression is the algebraic operator that binds it together. Suppose, however, we indexed the procedures in the opposite way, so that the dispatch line in deriv looked like
+
+((get (operator exp) 'deriv) (operands exp) var)
+
+What corresponding changes to the derivative system are required?
blob - /dev/null
blob + a5bf19b7d92ae76be916400631a76e4f2b351fe4 (mode 644)
--- /dev/null
+++ ex2-73.scm~
+(define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+(define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+(define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+(define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+
+(define (attach-tag type-tag contents)
+ (cons type-tag contents))
+(define (type-tag datum)
+ (if (pair? datum)
+ (car datum)
+ (error "Bad tagged datum -- TYPE-TAG" datum)))
+(define (contents datum)
+ (if (pair? datum)
+ (cdr datum)
+ (error "Bad tagged datum -- CONTENTS" datum)))
+(define (rectangular? z)
+ (eq? (type-tag z) 'rectangular))
+(define (polar? z)
+ (eq? (type-tag z) 'polar))
+
+(define (install-rectangular-package)
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (make-from-real-imag x y)
+ (cons x y))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z)
+ (atan (imag-part z) (real-part z)))
+ (define (make-from-mag-ang r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (install-polar-package)
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (make-from-mag-ang r a) (cons r a))
+ (define (real-part z)
+ (* (magnitude z) (cos (angle z))))
+ (define (imag-part z)
+ (* (magnitude z) (sin (angle z))))
+ (define (make-from-real-imag x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error
+ "No method for these types -- APPLY-GENERIC"
+ (list op type-tags)))))
+
+(define (real-part z) (apply-generic 'real-part z))
+(define (imag-part z) (apply-generic 'imag-part z))
+(define (magnitude z) (apply-generic 'magnitude z))
+(define (angle z) (apply-generic 'angle z))
+(define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+(define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ ((sum? exp)
+ (make-sum (deriv (addend exp) var)
+ (deriv (augend exp) var)))
+ ((product? exp)
+ (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp) var))
+ (make-product (deriv (multiplier exp) var)
+ (multiplicand exp))))
+ (else (error "unknown expression type -- DERIV" exp))))
+
+;; We can regard this program as performing a dispatch on the type of the expression to be differentiated. In this situation the ``type tag'' of the datum is the algebraic operator symbol (such as +) and the operation being performed is deriv. We can transform this program into data-directed style by rewriting the basic derivative procedure as
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ (else ((get 'deriv (operator exp)) (operands exp)
+ var))))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+
+;; a. Explain what was done above. Why can't we assimilate the predicates number? and same-variable? into the data-directed dispatch?
+
+;; If exp is a number, we return 0. If it is a variable and we are taking the derivative with respect the same variable, we return 1 (otherwise we return 0). Otherwise, we go to the operation-and-type table and look up the procedure with operation name 'deriv and data type with the same operator. We then apply this procedure on the operands of the expression (passed as a list) and the variable.
+
+;; We cannot assimilate the predicates because there are no operators for simple numbers and variables. These expressions are not lists.
+
+;; b. Write the procedures for derivatives of sums and products, and the auxiliary code required to install them in the table used by the program above.
+
+(define (first-operand operands)
+ (car operands))
+(define (rest-operands operands)
+ (cdr operands))
+(define (deriv-sum operands var)
+ (make-sum (deriv (first-operand operands) var)
+ (deriv (rest-operands operands) var)))
+(define (deriv-product operands var)
+ (make-sum
+ (make-product (first-operand operands)
+ (deriv (rest-operands operands) var))
+ (make-product (deriv (first-operand operands) var)
+ (rest-operands operands))))
+(put 'deriv '+ deriv-sum)
+(put 'deriv '* deriv-product)
+
+;; c. Choose any additional differentiation rule that you like, such as the one for exponents (exercise 2.56), and install it in this data-directed system.
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+ ((and (exponentiation? exp)
+ (number? (exponent exp)))
+ (make-product
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp) -1)))
+;; or (- (exponent exp) 1)
+ (deriv (base exp) var)))
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+
+(define (deriv-exp)
+
+d. In this simple algebraic manipulator the type of an expression is the algebraic operator that binds it together. Suppose, however, we indexed the procedures in the opposite way, so that the dispatch line in deriv looked like
+
+((get (operator exp) 'deriv) (operands exp) var)
+
+What corresponding changes to the derivative system are required?
blob - /dev/null
blob + 081cd536b12f2b25328c344a72c0f81409b4cd9c (mode 644)
--- /dev/null
+++ ex2-73b.scm
+(define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+(define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+(define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+(define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+
+(define (attach-tag type-tag contents)
+ (cons type-tag contents))
+(define (type-tag datum)
+ (if (pair? datum)
+ (car datum)
+ (error "Bad tagged datum -- TYPE-TAG" datum)))
+(define (contents datum)
+ (if (pair? datum)
+ (cdr datum)
+ (error "Bad tagged datum -- CONTENTS" datum)))
+(define (rectangular? z)
+ (eq? (type-tag z) 'rectangular))
+(define (polar? z)
+ (eq? (type-tag z) 'polar))
+
+(define (install-rectangular-package)
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (make-from-real-imag x y)
+ (cons x y))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z)
+ (atan (imag-part z) (real-part z)))
+ (define (make-from-mag-ang r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (install-polar-package)
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (make-from-mag-ang r a) (cons r a))
+ (define (real-part z)
+ (* (magnitude z) (cos (angle z))))
+ (define (imag-part z)
+ (* (magnitude z) (sin (angle z))))
+ (define (make-from-real-imag x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error
+ "No method for these types -- APPLY-GENERIC"
+ (list op type-tags)))))
+
+(define (real-part z) (apply-generic 'real-part z))
+(define (imag-part z) (apply-generic 'imag-part z))
+(define (magnitude z) (apply-generic 'magnitude z))
+(define (angle z) (apply-generic 'angle z))
+(define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+(define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+;; We can regard this program as performing a dispatch on the type of the expression to be differentiated. In this situation the ``type tag'' of the datum is the algebraic operator symbol (such as +) and the operation being performed is deriv. We can transform this program into data-directed style by rewriting the basic derivative procedure as
+
+(define (deriv exp var)
+ (cond ((number? exp) 0)
+ ((variable? exp) (if (same-variable? exp var) 1 0))
+ (else ((get 'deriv (operator exp)) (operands exp)
+ var))))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+
+;; a. Explain what was done above. Why can't we assimilate the predicates number? and same-variable? into the data-directed dispatch?
+
+;; If exp is a number, we return 0. If it is a variable and we are taking the derivative with respect the same variable, we return 1 (otherwise we return 0). Otherwise, we go to the operation-and-type table and look up the procedure with operation name 'deriv and data type with the same operator. We then apply this procedure on the operands of the expression (passed as a list) and the variable.
+
+;; We cannot assimilate the predicates because there are no operators for simple numbers and variables. These expressions are not lists.
+
+;; b. Write the procedures for derivatives of sums and products, and the auxiliary code required to install them in the table used by the program above.
+
+(define (deriv-sum operands var)
+ (make-sum (deriv (car operands) var)
+ (deriv (cadr operands) var)))
+(define (deriv-product operands var)
+ (let ((multiplier (car operands))
+ (multiplicand (cadr operands)))
+ (make-sum
+ (make-product multiplier
+ (deriv multiplicand var))
+ (make-product (deriv multiplier var)
+ multiplicand))))
+(put 'deriv '+ deriv-sum)
+(put 'deriv '* deriv-product)
+
+;; c. Choose any additional differentiation rule that you like, such as the one for exponents (exercise 2.56), and install it in this data-directed system.
+
+(define (exponentiation? exp)
+ (and (pair? exp) (eq? (car exp) '**)))
+(define (base exp)
+ (cadr exp))
+(define (exponent exp)
+ (caddr exp))
+(define (=number? x num)
+ (and (number? x) (= x num)))
+(define (make-exponentiation base exponent)
+ (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
+ ((=number? exponent 0) 1)
+ ((=number? base 0) 0)
+ ((=number? base 1) 1)
+ ((and (number? base) (number? exponent)) (expt base exponent))
+ ((=number? exponent 1) base)
+ (else (list '** base exponent))))
+
+(define (deriv-exp operands var)
+ (let ((base (car operands))
+ (exponent (cadr operands)))
+ (make-product (make-product
+ exponent
+ (make-exponentiation base (make-sum exponent -1)))
+ (deriv base var))))
+
+(put 'deriv '** deriv-exp)
+
+;; d. In this simple algebraic manipulator the type of an expression is the algebraic operator that binds it together. Suppose, however, we indexed the procedures in the opposite way, so that the dispatch line in deriv looked like
+
+;; ((get (operator exp) 'deriv) (operands exp) var)
+
+;; What corresponding changes to the derivative system are required?
+
+;; All we need to do is change the put operations to (put 'operator 'operations procedure-name)
+;; not a big deal
blob - /dev/null
blob + 68cce03be4d81159a9fcdafc2b85548704d15e79 (mode 644)
--- /dev/null
+++ ex2-74-sol.scm
+(define (make-generic-file division file)
+ (list division file))
+(define (division-of-generic-file gf)
+ (car gf))
+(define (file-of-generic-file gf)
+ (cadr gf))
+(define (get-record employee file)
+ ((get 'get-record
+ (division-of-generic-file file))
+ employee
+ (file-of-generic-file file)))
+(define (get-salary employee)
+ ((get 'get-salary
+ (division-of-generic-employee employee))
+ (employee-of-generic-employee employee)))
blob - /dev/null
blob + 73cb644c7d12da0f7900d8a8ea0facacef2c57ca (mode 644)
--- /dev/null
+++ ex2-74.scm
+;; Exercise 2.74. Insatiable Enterprises, Inc., is a highly decentralized conglomerate company consisting of a large number of independent divisions located all over the world. The company's computer facilities have just been interconnected by means of a clever network-interfacing scheme that makes the entire network appear to any user to be a single computer. Insatiable's president, in her first attempt to exploit the ability of the network to extract administrative information from division files, is dismayed to discover that, although all the division files have been implemented as data structures in Scheme, the particular data structure used varies from division to division. A meeting of division managers is hastily called to search for a strategy to integrate the files that will satisfy headquarters' needs while preserving the existing autonomy of the divisions.
+
+;; Show how such a strategy can be implemented with data-directed programming. As an example, suppose that each division's personnel records consist of a single file, which contains a set of records keyed on employees' names. The structure of the set varies from division to division. Furthermore, each employee's record is itself a set (structured differently from division to division) that contains information keyed under identifiers such as address and salary. In particular:
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "invalid operation/type"))))
+
+(define (attach-tag type-tag contents)
+ (cons type-tag contents))
+(define (type-tag datum)
+ (if (pair? datum)
+ (car datum)
+ (error "invalid datum")))
+(define (contents datum)
+ (if (pair? datum)
+ (cdr datum)
+ (error "invalid datum")))
+
+;; returns name of given record
+(define (name record)
+ (apply-generic 'name record))
+(define (address record)
+ (apply-generic 'address record))
+(define (salary record)
+ (apply-generic 'salary record))
+(define (make-file1-record1 name salary address other)
+ ((get 'make-file1-record1 '(file1 record1)) name salary address other))
+
+
+(define (install-file1)
+ (define (make-record1 name salary address other)
+ (list name salary address other))
+ (define (name-record1 record)
+ (car record))
+ ;; we'll implement the file as a simple unordered list
+ (define (in-file? file name)
+ (and (not (null? file))
+ (or (eq? (car file) name)
+ (cond ((null? file) #f)
+ ((eq? (car file) name) #t)
+ (else (in-file? (cdr file) name))))
+ (define
+ )
+ (put 'make-file1-record1
+ '(file1 record1)
+ (lambda (name salary address other)
+ (attach-tag '(file1 record1)
+ (make-record1 name salary address other))))
+
+ (put 'name '(file1 record1) ...)
+
+
+
+;; I should define an in-file? procedure and an add-record procedure instead
+
+;; (define (make-file-internal list-of-records)
+;; list-of-records)
+;; (put 'make-file 'file1 (lambda (list-of-records)
+;; (attach-tag 'file1 (make-file-interal list-of-records))))
+;; (define (make-file1 list-of-records)
+;; ((get 'make-file 'file1) list-of-records))
+
+;; a. Implement for headquarters a get-record procedure that retrieves a specified employee's record from a specified personnel file. The procedure should be applicable to any division's file. Explain how the individual divisions' files should be structured. In particular, what type information must be supplied?
+
+;; get specified record from specified file
+(define (get-record file name)
+ (apply-generic 'get-record file name))
+
+(define (get-record-file1 file name)
+ (cond ((null? file) (error "person not found" name))
+ ((eq? (car file) name) (car file))
+ (else (get-record-file1 (cdr file) name))))
+(put 'get-record '(file1 file1-record) get-record-file1)
+
+;; b. Implement for headquarters a get-salary procedure that returns the salary information from a given employee's record from any division's personnel file. How should the record be structured in order to make this operation work?
+
+;; c. Implement for headquarters a find-employee-record procedure. This should search all the divisions' files for the record of a given employee and return the record. Assume that this procedure takes as arguments an employee's name and a list of all the divisions' files.
+
+;; d. When Insatiable takes over a new company, what changes must be made in order to incorporate the new personnel information into the central system?
blob - /dev/null
blob + dca008fc5a5a03d4bd142967badd457ebed446ba (mode 644)
--- /dev/null
+++ ex2-74.scm~
+(define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+(define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+(define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+(define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+
+(define (attach-tag type-tag contents)
+ (cons type-tag contents))
+(define (type-tag datum)
+ (if (pair? datum)
+ (car datum)
+ (error "Bad tagged datum -- TYPE-TAG" datum)))
+(define (contents datum)
+ (if (pair? datum)
+ (cdr datum)
+ (error "Bad tagged datum -- CONTENTS" datum)))
+(define (rectangular? z)
+ (eq? (type-tag z) 'rectangular))
+(define (polar? z)
+ (eq? (type-tag z) 'polar))
+
+(define (install-rectangular-package)
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (make-from-real-imag x y)
+ (cons x y))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z)
+ (atan (imag-part z) (real-part z)))
+ (define (make-from-mag-ang r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (install-polar-package)
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (make-from-mag-ang r a) (cons r a))
+ (define (real-part z)
+ (* (magnitude z) (cos (angle z))))
+ (define (imag-part z)
+ (* (magnitude z) (sin (angle z))))
+ (define (make-from-real-imag x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error
+ "No method for these types -- APPLY-GENERIC"
+ (list op type-tags)))))
+
+(define (real-part z) (apply-generic 'real-part z))
+(define (imag-part z) (apply-generic 'imag-part z))
+(define (magnitude z) (apply-generic 'magnitude z))
+(define (angle z) (apply-generic 'angle z))
+(define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+(define (make-from-mag-ang r a)
+: ((get 'make-from-mag-ang 'polar) r a))
+
+;; Exercise 2.74. Insatiable Enterprises, Inc., is a highly decentralized conglomerate company consisting of a large number of independent divisions located all over the world. The company's computer facilities have just been interconnected by means of a clever network-interfacing scheme that makes the entire network appear to any user to be a single computer. Insatiable's president, in her first attempt to exploit the ability of the network to extract administrative information from division files, is dismayed to discover that, although all the division files have been implemented as data structures in Scheme, the particular data structure used varies from division to division. A meeting of division managers is hastily called to search for a strategy to integrate the files that will satisfy headquarters' needs while preserving the existing autonomy of the divisions.
+
+;; Show how such a strategy can be implemented with data-directed programming. As an example, suppose that each division's personnel records consist of a single file, which contains a set of records keyed on employees' names. The structure of the set varies from division to division. Furthermore, each employee's record is itself a set (structured differently from division to division) that contains information keyed under identifiers such as address and salary. In particular:
+
+;; a. Implement for headquarters a get-record procedure that retrieves a specified employee's record from a specified personnel file. The procedure should be applicable to any division's file. Explain how the individual divisions' files should be structured. In particular, what type information must be supplied?
+
+;; b. Implement for headquarters a get-salary procedure that returns the salary information from a given employee's record from any division's personnel file. How should the record be structured in order to make this operation work?
+
+;; c. Implement for headquarters a find-employee-record procedure. This should search all the divisions' files for the record of a given employee and return the record. Assume that this procedure takes as arguments an employee's name and a list of all the divisions' files.
+
+;; d. When Insatiable takes over a new company, what changes must be made in order to incorporate the new personnel information into the central system?
blob - /dev/null
blob + 0940cc82474644be3a6e0c8be90c9d97920ebc20 (mode 644)
--- /dev/null
+++ ex2-75.scm
+(define (make-from-real-imag x y)
+ (define (dispatch op)
+ (cond ((eq? op 'real-part) x)
+ ((eq? op 'imag-part) y)
+ ((eq? op 'magnitude)
+ (sqrt (+ (square x) (square y))))
+ ((eq? op 'angle) (atan y x))
+ (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
+ dispatch)
+
+(define (apply-generic op arg) (arg op))
+
+;; Exercise 2.75. Implement the constructor make-from-mag-ang in message-passing style. This procedure should be analogous to the make-from-real-imag procedure given above.
+
+(define (make-from-mag-ang r a)
+ (define (dispatch op)
+ (cond ((eq? op 'real-part) (* r (cos a)))
+ ((eq? op 'imag-part) (* r (sin a)))
+ ((eq? op 'magnitude) r)
+ ((eq? op 'angle) a)
+ (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
+ dispatch)
+
+
blob - /dev/null
blob + 6470f4c5cce628e2bd387490e0a39208164c03f4 (mode 644)
--- /dev/null
+++ ex2-75.scm~
+(define (make-from-real-imag x y)
+ (define (dispatch op)
+ (cond ((eq? op 'real-part) x)
+ ((eq? op 'imag-part) y)
+ ((eq? op 'magnitude)
+ (sqrt (+ (square x) (square y))))
+ ((eq? op 'angle) (atan y x))
+ (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
+ dispatch)
blob - /dev/null
blob + e855c0469c7466abf6b1ca59aea191a06ec66d2a (mode 644)
--- /dev/null
+++ ex2-76.scm
+(define (make-from-real-imag x y)
+ (define (dispatch op)
+ (cond ((eq? op 'real-part) x)
+ ((eq? op 'imag-part) y)
+ ((eq? op 'magnitude)
+ (sqrt (+ (square x) (square y))))
+ ((eq? op 'angle) (atan y x))
+ (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
+ dispatch)
+
+(define (apply-generic op arg) (arg op))
+
+;; Exercise 2.75. Implement the constructor make-from-mag-ang in message-passing style. This procedure should be analogous to the make-from-real-imag procedure given above.
+
+(define (make-from-mag-ang r a)
+ (define (dispatch op)
+ (cond ((eq? op 'real-part) (* r (cos a)))
+ ((eq? op 'imag-part) (* r (sin a)))
+ ((eq? op 'magnitude) r)
+ ((eq? op 'angle) a)
+ (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
+ dispatch)
+
+;; Exercise 2.76. As a large system with generic operations evolves, new types of data objects or new operations may be needed. For each of the three strategies -- generic operations with explicit dispatch, data-directed style, and message-passing-style -- describe the changes that must be made to a system in order to add new types or new operations. Which organization would be most appropriate for a system in which new types must often be added? Which would be most appropriate for a system in which new operations must often be added?
+
+;; For generic operations with explicit dispatch, you need to update every single one of the generic selectors each time you add a new data type. You'll also need to add a new constructor for that data type. If you add a new generic operation, all of the data types that want to support it will need to provide a procedure. The maintainer of the generic operation needs to know about all the data types in order to make a proper dispatch. Explicit dispatch is the most burdensome to maintain.
+
+;; For data-directed and message-passing style, each time you add a new data type, there is no need for the generic operation to be updated. For data-directed style, the implementor of the new data type just needs to put the corresponding procedure into the table. For message-passing style, a table does not even need to be updated. The implementor only needs to update his data object to learn how to handle any messages the object needs to support.
+
+;; When adding a new operation, for both cases, the implementor of the data type will need to add a new procedure (or learn how to respond to the new operation message) if the operation needs to be supported.
blob - /dev/null
blob + 0940cc82474644be3a6e0c8be90c9d97920ebc20 (mode 644)
--- /dev/null
+++ ex2-76.scm~
+(define (make-from-real-imag x y)
+ (define (dispatch op)
+ (cond ((eq? op 'real-part) x)
+ ((eq? op 'imag-part) y)
+ ((eq? op 'magnitude)
+ (sqrt (+ (square x) (square y))))
+ ((eq? op 'angle) (atan y x))
+ (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
+ dispatch)
+
+(define (apply-generic op arg) (arg op))
+
+;; Exercise 2.75. Implement the constructor make-from-mag-ang in message-passing style. This procedure should be analogous to the make-from-real-imag procedure given above.
+
+(define (make-from-mag-ang r a)
+ (define (dispatch op)
+ (cond ((eq? op 'real-part) (* r (cos a)))
+ ((eq? op 'imag-part) (* r (sin a)))
+ ((eq? op 'magnitude) r)
+ ((eq? op 'angle) a)
+ (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
+ dispatch)
+
+
blob - /dev/null
blob + 1eee3e63f7a4f024b0ffa9a619253386fa3bf4dd (mode 644)
--- /dev/null
+++ ex2-77.scm
+(define (attach-tag type-tag contents)
+ (cons type-tag contents))
+(define (type-tag datum)
+ (if (pair? datum)
+ (car datum)
+ (error "error -- invalid datum" datum)))
+(define (contents datum)
+ (if (pair? datum)
+ (cdr datum)
+ (error "error -- invalid datum" datum)))
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "error -- procedure not found" (list op args)))))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done))
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
blob - /dev/null
blob + 92bddd9d88f24d3a797532da14f11af222424846 (mode 644)
--- /dev/null
+++ ex2-77.scm~
+(define (attach-tag type-tag contents)
+ (cons type-tag contents))
+(define (type-tag datum)
+ (if (pair? datum)
+ (car datum)
+ (error "invalid datum -- TYPE-TAG" datum)))
+(define (contents datum)
+ (if (pair? datum)
+ (cdr datum)
+ (error "invalid datum -- TYPE-TAG" datum)))
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "procedure not found -- APPLY-GENERIC" (list op args)))))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+
+(define (install-scheme-number-package)
+ (define (tag x)
+ (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'make 'scheme-number
+ (lambda (x) (tag x)))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+
+(define (install-rational-package)
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational) (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational) (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational) (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational) (lambda (x y) (tag (div-rat x y))))
+ (put 'make 'rational (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complez x1 x2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (tag z) (attach-tag 'complex z))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
blob - /dev/null
blob + a6f3cefa6cfca0d769007bb290ccf48fe4298612 (mode 644)
--- /dev/null
+++ ex2-77b.scm
+(define (attach-tag type-tag contents)
+ (cons type-tag contents))
+(define (type-tag datum)
+ (if (pair? datum)
+ (car datum)
+ (error "error -- invalid datum" datum)))
+(define (contents datum)
+ (if (pair? datum)
+ (cdr datum)
+ (error "error -- invalid datum" datum)))
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "error -- procedure not found" (list op args)))))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done))
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; Exercise 2.77. Louis Reasoner tries to evaluate the expression (magnitude z) where z is the object shown in figure 2.24. To his surprise, instead of the answer 5 he gets an error message from apply-generic, saying there is no method for the operation magnitude on the types (complex). He shows this interaction to Alyssa P. Hacker, who says ``The problem is that the complex-number selectors were never defined for complex numbers, just for polar and rectangular numbers. All you have to do to make this work is add the following to the complex package:''
+
+(put 'real-part '(complex) real-part)
+(put 'imag-part '(complex) imag-part)
+(put 'magnitude '(complex) magnitude)
+(put 'angle '(complex) angle)
+
+;; We are exporting the selectors which are inside the complex package and putting them in the operation-and-type-table so that the generic procedures dispatch on type. These selectors are themselves generic procedures which depend upon selectors implemented in the rectangular/polar procedures which were exported to the operation-and-type-table.
+
+What happens is that we have a datum z. Since it is a complex number, it is dispatched to the complex package after being stripped of its tag. This datum is then identified as a rectangular number, stripped of its tag, and dispatched to the rectangular package.
+
+(define (real-part z) (apply-generic 'real-part z))
+(define (imag-part z) (apply-generic 'imag-part z))
+(define (magnitude z) (apply-generic 'magnitude z))
+(define (angle z) (apply-generic 'angle z))
+
+;; Describe in detail why this works. As an example, trace through all the procedures called in evaluating the expression (magnitude z) where z is the object shown in figure 2.24. In particular, how many times is apply-generic invoked? What procedure is dispatched to in each case?
+
+A single call to (magnitude z) from outside the packages ends up as follows:
+The tag identifies that z is a complex number. The appropriate procedure of operation 'magnitude and type '(complex) is called on the contents of z (which is a datum typed as 'rectangular). This procedure is itself a generic selector, so the datum it receives is identified as type 'rectangular. The rectangular procedure is then called on the contents of z.
+
+Apply-generic is invoked twice.
blob - /dev/null
blob + 1eee3e63f7a4f024b0ffa9a619253386fa3bf4dd (mode 644)
--- /dev/null
+++ ex2-77b.scm~
+(define (attach-tag type-tag contents)
+ (cons type-tag contents))
+(define (type-tag datum)
+ (if (pair? datum)
+ (car datum)
+ (error "error -- invalid datum" datum)))
+(define (contents datum)
+ (if (pair? datum)
+ (cdr datum)
+ (error "error -- invalid datum" datum)))
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "error -- procedure not found" (list op args)))))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done))
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
blob - /dev/null
blob + 4388bba41d82bdf68eda64554e8d7806deb92ecc (mode 644)
--- /dev/null
+++ ex2-78-sol.scm
+(define (attach-tag type-tag contents)
+ (if (number? contents)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ (else (error "Bad tagged datum -- TYPE-TAG" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ (else (error "Bad tagged datum -- TYPE-TAG" datum))))
+
+(put 'real-part '(complex) real-part)
+(put 'imag-part '(complex) imag-part)
+(put 'magnitude '(complex) magnitude)
+(put 'angle '(complex) angle)
+
blob - /dev/null
blob + fc62b8f66eb5f851c29827581659c3844cba743a (mode 644)
--- /dev/null
+++ ex2-78-sol.scm~
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error
+ "No method for these types -- APPLY-GENERIC"
+ (list op type-tags))))))
+
+(define (attach-tag type-tag contents)
blob - /dev/null
blob + bd72318632956925a39dd9ec8aca1d767fad7443 (mode 644)
--- /dev/null
+++ ex2-78.scm
+(define (attach-tag type-tag contents)
+ (cons type-tag contents))
+(define (type-tag datum)
+ (if (pair? datum)
+ (car datum)
+ (error "error -- invalid datum" datum)))
+(define (contents datum)
+ (if (pair? datum)
+ (cdr datum)
+ (error "error -- invalid datum" datum)))
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "error -- procedure not found" (list op args)))))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done))
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; Exercise 2.78. The internal procedures in the scheme-number package are essentially nothing more than calls to the primitive procedures +, -, etc. It was not possible to use the primitives of the language directly because our type-tag system requires that each data object have a type attached to it. In fact, however, all Lisp implementations do have a type system, which they use internally. Primitive predicates such as symbol? and number? determine whether data objects have particular types. Modify the definitions of type-tag, contents, and attach-tag from section 2.4.2 so that our generic system takes advantage of Scheme's internal type system. That is to say, the system should work as before except that ordinary numbers should be represented simply as Scheme numbers rather than as pairs whose car is the symbol scheme-number.
+
+(define (attach-tag type-tag contents)
+ (if (eq? type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define get 2d-get)
+(define put 2d-put!)
+
+(define (install-scheme-number-package)
+(define (install-rational-package)
+(define (install-complex-package)
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+
+
+(test-case (make-scheme-number 5) 5)
+(test-case (make-
blob - /dev/null
blob + c388a33468cf23f921b66026bea3d614e49a42e8 (mode 644)
--- /dev/null
+++ ex2-78.scm~
+(define (attach-tag type-tag contents)
+ (cons type-tag contents))
+(define (type-tag datum)
+ (if (pair? datum)
+ (car datum)
+ (error "error -- invalid datum" datum)))
+(define (contents datum)
+ (if (pair? datum)
+ (cdr datum)
+ (error "error -- invalid datum" datum)))
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "error -- procedure not found" (list op args)))))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done))
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; Exercise 2.78. The internal procedures in the scheme-number package are essentially nothing more than calls to the primitive procedures +, -, etc. It was not possible to use the primitives of the language directly because our type-tag system requires that each data object have a type attached to it. In fact, however, all Lisp implementations do have a type system, which they use internally. Primitive predicates such as symbol? and number? determine whether data objects have particular types. Modify the definitions of type-tag, contents, and attach-tag from section 2.4.2 so that our generic system takes advantage of Scheme's internal type system. That is to say, the system should work as before except that ordinary numbers should be represented simply as Scheme numbers rather than as pairs whose car is the symbol scheme-number.
+
+(define (attach-tag type-tag contents)
+ (if (eq? type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (make-scheme-number 5) 5)
+(test-case (make-
blob - /dev/null
blob + af30b418c145d19bd4fe9a17ef8869a0b198434b (mode 644)
--- /dev/null
+++ ex2-78b.scm
+;; Exercise 2.78. The internal procedures in the scheme-number package are essentially nothing more than calls to the primitive procedures +, -, etc. It was not possible to use the primitives of the language directly because our type-tag system requires that each data object have a type attached to it. In fact, however, all Lisp implementations do have a type system, which they use internally. Primitive predicates such as symbol? and number? determine whether data objects have particular types. Modify the definitions of type-tag, contents, and attach-tag from section 2.4.2 so that our generic system takes advantage of Scheme's internal type system. That is to say, the system should work as before except that ordinary numbers should be represented simply as Scheme numbers rather than as pairs whose car is the symbol scheme-number.
+
+(define (attach-tag type-tag contents)
+ (if (eq? type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; (define get 2d-get)
+;; (define put 2d-put!)
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "error -- procedure not found" (list op args)))))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+
+;; install number packages
+
+(install-scheme-number-package)
+(install-rational-package)
+(install-complex-package)
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (make-scheme-number 5) 5)
+(test-case (contents (make-scheme-number 4)) 4)
+(test-case (type-tag 5) 'scheme-number)
+(test-case (add (make-scheme-number 5)
+ (make-scheme-number 5))
+ 10)
+(test-case
+ (div (make-scheme-number -12)
+ (sub (make-scheme-number 4)
+ (mul (make-scheme-number 3)
+ (make-scheme-number 2))))
+ 6)
+
+(test-case (type-tag (make-rational 5 6)) 'rational)
+(test-case (contents (make-rational 5 6)) (cons 5 6))
+(test-case (add (sub (add (make-rational 5 6)
+ (make-rational 3 4))
+ (mul (make-rational 2 4)
+ (make-rational 1 4)))
+ (div (make-rational 3 4)
+ (make-rational 1 2)))
+ (cons 'rational (cons 71 24)))
+
+(test-case (add (sub (add (make-complex-from-real-imag 5 6)
+ (make-complex-from-mag-ang 3 4))
+ (mul (make-complex-from-mag-ang 2 4)
+ (make-complex-from-real-imag 1 4)))
+ (div (make-complex-from-real-imag 3 4)
+ (make-complex-from-mag-ang 1 2)))
+ (cons 'complex (cons 'rectangular (cons 0.68068565 6.07986688))))
+
blob - /dev/null
blob + c9c7f6a2bf683daed21e394f505d774632d7e9a5 (mode 644)
--- /dev/null
+++ ex2-78b.scm~
+(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+
+(define (make-table)
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- Table" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "error -- procedure not found" (list op args)))))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (display "tag installed")
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (display "add installed")
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ (display "grabbing procedure")
+ (test-case ((get 'add '(scheme-number scheme-number)) 3 4) 7)
+ (display "procedure grabbed")
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+
+;; install number packages
+
+(install-scheme-number-package)
+(install-rational-package)
+(install-complex-package)
+
+
+;; Exercise 2.78. The internal procedures in the scheme-number package are essentially nothing more than calls to the primitive procedures +, -, etc. It was not possible to use the primitives of the language directly because our type-tag system requires that each data object have a type attached to it. In fact, however, all Lisp implementations do have a type system, which they use internally. Primitive predicates such as symbol? and number? determine whether data objects have particular types. Modify the definitions of type-tag, contents, and attach-tag from section 2.4.2 so that our generic system takes advantage of Scheme's internal type system. That is to say, the system should work as before except that ordinary numbers should be represented simply as Scheme numbers rather than as pairs whose car is the symbol scheme-number.
+
+(define (attach-tag type-tag contents)
+ (if (eq? type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (make-scheme-number 5) 5)
+(test-case (add (make-scheme-number 5)
+ (make-scheme-number 5))
+ 10)
+(test-case
+ (div (make-scheme-number -12)
+ (subtract (make-scheme-number 4)
+ (mul (make-scheme-number 3)
+ (make-scheme-number 2))))
+ 6)
blob - /dev/null
blob + 55e1ff07e1a05a3aa98dc559268e1403a0855da0 (mode 644)
--- /dev/null
+++ ex2-79-sol.scm
+(define (=zero?
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + f0b488870253040ee0dce7897415ac3efbdb8b97 (mode 644)
--- /dev/null
+++ ex2-79.scm
+;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
+
+(define (attach-tag type-tag contents)
+ (if (eq? type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "error -- procedure not found" (list op args)))))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(scheme-number scheme-number) =)
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'equ? '(rational rational) equ-rat?)
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ (put 'equ? '(complex complex) equ-complex?)
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+
+;; install number packages
+
+(install-scheme-number-package)
+(install-rational-package)
+(install-complex-package)
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (equ? (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (div (make-scheme-number 80)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #f)
+(test-case (equ? (div (make-rational 4 3)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
blob - /dev/null
blob + af30b418c145d19bd4fe9a17ef8869a0b198434b (mode 644)
--- /dev/null
+++ ex2-79.scm~
+;; Exercise 2.78. The internal procedures in the scheme-number package are essentially nothing more than calls to the primitive procedures +, -, etc. It was not possible to use the primitives of the language directly because our type-tag system requires that each data object have a type attached to it. In fact, however, all Lisp implementations do have a type system, which they use internally. Primitive predicates such as symbol? and number? determine whether data objects have particular types. Modify the definitions of type-tag, contents, and attach-tag from section 2.4.2 so that our generic system takes advantage of Scheme's internal type system. That is to say, the system should work as before except that ordinary numbers should be represented simply as Scheme numbers rather than as pairs whose car is the symbol scheme-number.
+
+(define (attach-tag type-tag contents)
+ (if (eq? type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; (define get 2d-get)
+;; (define put 2d-put!)
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "error -- procedure not found" (list op args)))))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+
+;; install number packages
+
+(install-scheme-number-package)
+(install-rational-package)
+(install-complex-package)
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (make-scheme-number 5) 5)
+(test-case (contents (make-scheme-number 4)) 4)
+(test-case (type-tag 5) 'scheme-number)
+(test-case (add (make-scheme-number 5)
+ (make-scheme-number 5))
+ 10)
+(test-case
+ (div (make-scheme-number -12)
+ (sub (make-scheme-number 4)
+ (mul (make-scheme-number 3)
+ (make-scheme-number 2))))
+ 6)
+
+(test-case (type-tag (make-rational 5 6)) 'rational)
+(test-case (contents (make-rational 5 6)) (cons 5 6))
+(test-case (add (sub (add (make-rational 5 6)
+ (make-rational 3 4))
+ (mul (make-rational 2 4)
+ (make-rational 1 4)))
+ (div (make-rational 3 4)
+ (make-rational 1 2)))
+ (cons 'rational (cons 71 24)))
+
+(test-case (add (sub (add (make-complex-from-real-imag 5 6)
+ (make-complex-from-mag-ang 3 4))
+ (mul (make-complex-from-mag-ang 2 4)
+ (make-complex-from-real-imag 1 4)))
+ (div (make-complex-from-real-imag 3 4)
+ (make-complex-from-mag-ang 1 2)))
+ (cons 'complex (cons 'rectangular (cons 0.68068565 6.07986688))))
+
blob - /dev/null
blob + 7629edb3dd491ddfb01288bbacdff297468a58b0 (mode 644)
--- /dev/null
+++ ex2-8.lisp
+(defun sub-interval (x y)
+ (make-interval
+ (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
blob - /dev/null
blob + f5c3d074ada01a62ba625420640975e35b7e8b21 (mode 644)
--- /dev/null
+++ ex2-8.scm
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+(define (mul-interval x y)
+ (let ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (div-interval x y)
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+
+;; Exercise 2.8. Using reasoning analogous to Alyssa's, describe how the difference of two intervals may be computed. Define a corresponding subtraction procedure, called sub-interval.
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
blob - /dev/null
blob + 55f82533de4af68dba5fb302180c789ae30ca9d8 (mode 644)
--- /dev/null
+++ ex2-8.scm~
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+(define (mul-interval x y)
+ (let ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (div-interval x y)
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))
+
+(define (make-interval a b)
+ (cons a b))
+(define (upper-bound x)
+ (cdr x))
+(define (lower-bound x)
+ (car x))
+
+
blob - /dev/null
blob + d4a64ea4629bd24231823149d19fb2cd1ad96c03 (mode 644)
--- /dev/null
+++ ex2-80.scm
+;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
+
+;; Exercise 2.80. Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
+
+(define (attach-tag type-tag contents)
+ (if (eq? type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "error -- procedure not found" (list op args)))))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(scheme-number scheme-number) =)
+ (put '=zero? '(scheme-number) zero?)
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+
+;; install number packages
+
+(install-scheme-number-package)
+(install-rational-package)
+(install-complex-package)
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (equ? (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (div (make-scheme-number 80)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #f)
+(test-case (equ? (div (make-rational 4 3)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5))))
+ #t)
+(test-case (=zero? (sub (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))))
+ #t)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+(test-case (=zero? (sub (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 3.5)
+ (make-scheme-number 5))))
+ #f)
+(test-case (=zero? (sub (div (make-rational 4 3)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
blob - /dev/null
blob + f0b488870253040ee0dce7897415ac3efbdb8b97 (mode 644)
--- /dev/null
+++ ex2-80.scm~
+;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
+
+(define (attach-tag type-tag contents)
+ (if (eq? type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "error -- procedure not found" (list op args)))))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(scheme-number scheme-number) =)
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'equ? '(rational rational) equ-rat?)
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ (put 'equ? '(complex complex) equ-complex?)
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+
+;; install number packages
+
+(install-scheme-number-package)
+(install-rational-package)
+(install-complex-package)
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (equ? (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (div (make-scheme-number 80)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #f)
+(test-case (equ? (div (make-rational 4 3)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
blob - /dev/null
blob + 42af55dc870e4b9e1d18196b924d1aefedddcd89 (mode 644)
--- /dev/null
+++ ex2-81-sol.scm
+(define (attach-tag type-tag contents)
+ (if (number? contents)
+ contents
+ (cons type-tag contents)))
+
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error "No method for these types -- APPLY-GENERIC"
+ (list op type-tags))))))
+
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args)))
+ (let ((t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond (t1->t2
+ (apply-generic op (t1->t2 a1) a2))
+ (t2->t1
+ (apply-generic op a1 (t2->t1 a2)))
+ (else
+ (error "No method for these types"
+ (list op type-tags))))))
+ (error "No method for these types"
+ (list op type-tags)))))))
+
blob - /dev/null
blob + e7d30742614ea8b925ce019d01c80d2c1c5e5ee2 (mode 644)
--- /dev/null
+++ ex2-81.scm
+;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
+
+;; Exercise 2.80. Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
+
+(define (attach-tag type-tag contents)
+ (if (eq? type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+(define coercion-table (make-table))
+(define get-coercion (coercion-table 'lookup-proc))
+(define put-coercion (operation-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(scheme-number scheme-number) =)
+ (put '=zero? '(scheme-number) zero?)
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+
+;; install number packages
+
+(install-scheme-number-package)
+(install-rational-package)
+(install-complex-package)
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (equ? (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (div (make-scheme-number 80)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #f)
+(test-case (equ? (div (make-rational 4 3)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5))))
+ #t)
+(test-case (=zero? (sub (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))))
+ #t)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+(test-case (=zero? (sub (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 3.5)
+ (make-scheme-number 5))))
+ #f)
+(test-case (=zero? (sub (div (make-rational 4 3)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+
+(define (scheme-number->complex n)
+ (make-complex-from-real-imag (contents n) 0))
+(put-coercion 'scheme-number 'complex scheme-number->complex)
+
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args)))
+ (let ((t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond (t1->t2
+ (apply-generic op (t1->t2 a1) a2))
+ (t2->t1
+ (apply-generic op a1 (t2->t1 a2)))
+ (else
+ (error "No method for these types"
+ (list op type-tags))))))
+ (error "No method for these types"
+ (list op type-tags)))))))
+
+
+;; Exercise 2.81. Louis Reasoner has noticed that apply-generic may try to coerce the arguments to each other's type even if they already have the same type. Therefore, he reasons, we need to put procedures in the coercion table to "coerce" arguments of each type to their own type. For example, in addition to the scheme-number->complex coercion shown above, he would do:
+
+(define (scheme-number->scheme-number n) n)
+(define (complex->complex z) z)
+(put-coercion 'scheme-number 'scheme-number
+ scheme-number->scheme-number)
+(put-coercion 'complex 'complex complex->complex)
+
+;; a. With Louis's coercion procedures installed, what happens if apply-generic is called with two arguments of type scheme-number or two arguments of type complex for an operation that is not found in the table for those types? For example, assume that we've defined a generic exponentiation operation:
+
+(define (exp x y) (apply-generic 'exp x y))
+
+;; and have put a procedure for exponentiation in the Scheme-number package but not in any other package:
+
+;; following added to Scheme-number package
+(put 'exp '(scheme-number scheme-number)
+ (lambda (x y) (tag (expt x y)))) ; using primitive expt
+
+;; What happens if we call exp with two complex numbers as arguments?
+
+;; the proper procedure will not be found, so apply-generic will look up the coercion procedure to coerce the first complex number to another complex number, then apply the procedure again. This will result in infinite recursion.
+
+;; b. Is Louis correct that something had to be done about coercion with arguments of the same type, or does apply-generic work correctly as is?
+
+;; No, Louis is wrong. Nothing needs to be done abotu coercion with arguments of the same type. His coercion procedures actually cause apply-generic to fail; apply-generic works correctly as-is.
+
+;; c. Modify apply-generic so that it doesn't try coercion if the two arguments have the same type.
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags)))
+ (if (equal? type1 type2)
+ (error "No method for these types"
+ (list op args))
+ (let ((a1 (car args))
+ (a2 (cadr args))
+ (t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond ((t1->t2 (apply-generic op (t1->t2 a1) a2))
+ (t2->t1 (apply-generic op a1 (t2->t1 a2)))
+ (else (error "No method for these types"
+ (list op args))))))))
+ (error "No method for these types"
+ (list op args))))))
+
+;; Exercise 2.82. Show how to generalize apply-generic to handle coercion in the general case of multiple arguments. One strategy is to attempt to coerce all the arguments to the type of the first argument, then to the type of the second argument, and so on. Give an example of a situation where this strategy (and likewise the two-argument version given above) is not sufficiently general. (Hint: Consider the case where there are some suitable mixed-type operations present in the table that will not be tried.)
blob - /dev/null
blob + fc4f74b44773357e9d4067e2042dc4a73875680c (mode 644)
--- /dev/null
+++ ex2-81.scm~
+;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
+
+;; Exercise 2.80. Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
+
+(define (attach-tag type-tag contents)
+ (if (eq? type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+(define coercion-table (make-table))
+(define get-coercion (coercion-table 'lookup-proc))
+(define put-coercion (operation-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(scheme-number scheme-number) =)
+ (put '=zero? '(scheme-number) zero?)
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+
+;; install number packages
+
+(install-scheme-number-package)
+(install-rational-package)
+(install-complex-package)
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (equ? (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (div (make-scheme-number 80)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #f)
+(test-case (equ? (div (make-rational 4 3)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5))))
+ #t)
+(test-case (=zero? (sub (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))))
+ #t)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+(test-case (=zero? (sub (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 3.5)
+ (make-scheme-number 5))))
+ #f)
+(test-case (=zero? (sub (div (make-rational 4 3)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+
+(define (scheme-number->complex n)
+ (make-complex-from-real-imag (contents n) 0))
+(put-coercion 'scheme-number 'complex scheme-number->complex)
+
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args)))
+ (let ((t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond (t1->t2
+ (apply-generic op (t1->t2 a1) a2))
+ (t2->t1
+ (apply-generic op a1 (t2->t1 a2)))
+ (else
+ (error "No method for these types"
+ (list op type-tags))))))
+ (error "No method for these types"
+ (list op type-tags)))))))
+
+
+;; Exercise 2.81. Louis Reasoner has noticed that apply-generic may try to coerce the arguments to each other's type even if they already have the same type. Therefore, he reasons, we need to put procedures in the coercion table to "coerce" arguments of each type to their own type. For example, in addition to the scheme-number->complex coercion shown above, he would do:
+
+(define (scheme-number->scheme-number n) n)
+(define (complex->complex z) z)
+(put-coercion 'scheme-number 'scheme-number
+ scheme-number->scheme-number)
+(put-coercion 'complex 'complex complex->complex)
+
+;; a. With Louis's coercion procedures installed, what happens if apply-generic is called with two arguments of type scheme-number or two arguments of type complex for an operation that is not found in the table for those types? For example, assume that we've defined a generic exponentiation operation:
+
+(define (exp x y) (apply-generic 'exp x y))
+
+;; and have put a procedure for exponentiation in the Scheme-number package but not in any other package:
+
+;; following added to Scheme-number package
+(put 'exp '(scheme-number scheme-number)
+ (lambda (x y) (tag (expt x y)))) ; using primitive expt
+
+;; What happens if we call exp with two complex numbers as arguments?
+
+;; the proper procedure will not be found, so apply-generic will look up the coercion procedure to coerce the first complex number to another complex number, then apply the procedure again. This will result in infinite recursion.
+
+;; b. Is Louis correct that something had to be done about coercion with arguments of the same type, or does apply-generic work correctly as is?
+
+;; No, Louis is wrong. Nothing needs to be done abotu coercion with arguments of the same type. His coercion procedures actually cause apply-generic to fail; apply-generic works correctly as-is.
+
+;; c. Modify apply-generic so that it doesn't try coercion if the two arguments have the same type.
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (and (= (length args) 2)
+ (let* ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args))
+ (t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond ((eq? type1 type2) (error "No method for these types"
+ (list op args)))
+ ;; probably should do some data abstraction instead
+ ;; of this ugly hack
+ (t1->t2 (apply-generic op (t1->t2 a1) a2))
+ (t2->t1 (apply-generic op a1 (t2->t1 a2)))
+ (else (error "No method for these types"
+ (list op args)))))
+ (error "No method for these types"
+ (list op args))))))
+
+;; Exercise 2.82. Show how to generalize apply-generic to handle coercion in the general case of multiple arguments. One strategy is to attempt to coerce all the arguments to the type of the first argument, then to the type of the second argument, and so on. Give an example of a situation where this strategy (and likewise the two-argument version given above) is not sufficiently general. (Hint: Consider the case where there are some suitable mixed-type operations present in the table that will not be tried.)
blob - /dev/null
blob + 123fd26292123822a5a01001f733d3cbd406d8ff (mode 644)
--- /dev/null
+++ ex2-82-sol.scm
+(define (apply-generic op . args)
+ (define (can-coerce-into? types target-type)
+ (andmap (lambda (type)
+ (or (equal? type target-type)
+ (get-coercion type target-type)))
+ types))
+ (define (find-coercion-target types)
+ (ormap
+ (lambda (target-type)
+ (if (can-coerce-into? types target-type)
+ target-type
+ #f))
+ types))
+ (define (coerce-all args target-type)
+ (map (lambda (arg)
+ (let ((arg-type (type-tag arg)))
+ (if (equal? arg-type target-type)
+ arg
+ ((get-coercion arg-type target-type) arg))))
+ args))
+ (define (no-method type-tags)
+ (error "No method for these types"
+ (list op type-tags)))
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (let ((target-type (find-coercion-target type-tags)))
+ (if target-type
+ (apply
+ apply-generic
+ (append (list op)
+ (coerce-all args target-type)))
+ (no-method type-tags)))))))
blob - /dev/null
blob + 1ac80f5ec4498367bdc9c764d9a5b6fa77493973 (mode 644)
--- /dev/null
+++ ex2-82-sol.scm~
+(define (apply-generic op . args)
+ (define (can-coerce-into? types target-type)
+ (andmap
blob - /dev/null
blob + 60943f347e76458c432c8faf66119b530f7936a1 (mode 644)
--- /dev/null
+++ ex2-82.scm
+;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
+
+;; Exercise 2.80. Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
+
+(define (attach-tag type-tag contents)
+ (if (eq? type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+(define coercion-table (make-table))
+(define get-coercion (coercion-table 'lookup-proc))
+(define put-coercion (coercion-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(scheme-number scheme-number) =)
+ (put '=zero? '(scheme-number) zero?)
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+
+;; install number packages
+
+(install-scheme-number-package)
+(install-rational-package)
+(install-complex-package)
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (equ? (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (div (make-scheme-number 80)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #f)
+(test-case (equ? (div (make-rational 4 3)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5))))
+ #t)
+(test-case (=zero? (sub (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))))
+ #t)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+(test-case (=zero? (sub (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 3.5)
+ (make-scheme-number 5))))
+ #f)
+(test-case (=zero? (sub (div (make-rational 4 3)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+(define (scheme-number->complex n)
+ (make-complex-from-real-imag (contents n) 0))
+(put-coercion 'scheme-number 'complex scheme-number->complex)
+
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args)))
+ (let ((t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond (t1->t2
+ (apply-generic op (t1->t2 a1) a2))
+ (t2->t1
+ (apply-generic op a1 (t2->t1 a2)))
+ (else
+ (display "test")
+ (error "No method for these types"
+ (list op type-tags))))))
+ (error "No method for these types"
+ (list op type-tags)))))))
+
+
+(test-case (add (make-scheme-number 5)
+ (make-complex-from-real-imag 3 2))
+ '(complex rectangular 8 . 2))
+(test-case (add (make-complex-from-mag-ang 5 0.927295218)
+ (make-scheme-number 2))
+ '(complex rectangular 5 . 4))
+
+;; Exercise 2.82. Show how to generalize apply-generic to handle coercion in the general case of multiple arguments. One strategy is to attempt to coerce all the arguments to the type of the first argument, then to the type of the second argument, and so on. Give an example of a situation where this strategy (and likewise the two-argument version given above) is not sufficiently general. (Hint: Consider the case where there are some suitable mixed-type operations present in the table that will not be tried.)
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (let* ((all-coercions ;; 2d-list of coercion procedures
+ (map (lambda (to-tag)
+ (map (lambda (from-tag)
+ (if (equal? from-tag to-tag)
+ #t
+ (get-coercion from-tag to-tag)))
+ type-tags))
+ type-tags))
+ (valid-coercions
+ (filter (lambda (coercions)
+ (fold-left and #t coercions))
+ all-coercions)))
+ ;; #t if same type or if coercion procedure exists
+ (if (null? valid-coercions)
+ (error "No method for these types"
+ (list op type-tags))
+ (apply apply-generic
+ (cons op
+ (map (lambda (coerce arg)
+ (if (equal? coerce 'same-tag)
+ arg
+ (coerce arg)))
+ (car valid-coercions)
+ args))))))))
+ ;; use the first to-type that all arguments can be coerced to
+
+;; It might be the case that a mixed-type operation would work where trying to force everything to the same type might not. For example, a contrived operation might work for data types '(float complex int) if we coerce float to complex to get '(complex complex int) but may not work with '(complex complex complex) or '(int int int).
+
+;; or maybe a supertype might work. Say we want to add '(imaginary real), then we might want to promote both to complex then add
blob - /dev/null
blob + e7d30742614ea8b925ce019d01c80d2c1c5e5ee2 (mode 644)
--- /dev/null
+++ ex2-82.scm~
+;; Exercise 2.79. Define a generic equality predicate equ? that tests the equality of two numbers, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
+
+;; Exercise 2.80. Define a generic predicate =zero? that tests if its argument is zero, and install it in the generic arithmetic package. This operation should work for ordinary numbers, rational numbers, and complex numbers.
+
+(define (attach-tag type-tag contents)
+ (if (eq? type-tag 'scheme-number)
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((number? datum) 'scheme-number)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((number? datum) datum)
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+(define coercion-table (make-table))
+(define get-coercion (coercion-table 'lookup-proc))
+(define put-coercion (operation-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+
+(define (install-scheme-number-package)
+ (define (tag x) (attach-tag 'scheme-number x))
+ (put 'add '(scheme-number scheme-number)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(scheme-number scheme-number)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(scheme-number scheme-number)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(scheme-number scheme-number)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(scheme-number scheme-number) =)
+ (put '=zero? '(scheme-number) zero?)
+ (put 'make 'scheme-number
+ (lambda (n) (tag n)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-scheme-number n)
+ ((get 'make 'scheme-number) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+
+;; install number packages
+
+(install-scheme-number-package)
+(install-rational-package)
+(install-complex-package)
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (equ? (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (div (make-scheme-number 80)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5)))
+ #f)
+(test-case (equ? (div (make-rational 4 3)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4))))
+ #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 4)
+ (make-scheme-number 5))))
+ #t)
+(test-case (=zero? (sub (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))))
+ #t)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+(test-case (=zero? (sub (div (make-scheme-number 81)
+ (mul (make-scheme-number 2)
+ (make-scheme-number 4.5)))
+ (add (make-scheme-number 3.5)
+ (make-scheme-number 5))))
+ #f)
+(test-case (=zero? (sub (div (make-rational 4 3)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+
+(define (scheme-number->complex n)
+ (make-complex-from-real-imag (contents n) 0))
+(put-coercion 'scheme-number 'complex scheme-number->complex)
+
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args)))
+ (let ((t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond (t1->t2
+ (apply-generic op (t1->t2 a1) a2))
+ (t2->t1
+ (apply-generic op a1 (t2->t1 a2)))
+ (else
+ (error "No method for these types"
+ (list op type-tags))))))
+ (error "No method for these types"
+ (list op type-tags)))))))
+
+
+;; Exercise 2.81. Louis Reasoner has noticed that apply-generic may try to coerce the arguments to each other's type even if they already have the same type. Therefore, he reasons, we need to put procedures in the coercion table to "coerce" arguments of each type to their own type. For example, in addition to the scheme-number->complex coercion shown above, he would do:
+
+(define (scheme-number->scheme-number n) n)
+(define (complex->complex z) z)
+(put-coercion 'scheme-number 'scheme-number
+ scheme-number->scheme-number)
+(put-coercion 'complex 'complex complex->complex)
+
+;; a. With Louis's coercion procedures installed, what happens if apply-generic is called with two arguments of type scheme-number or two arguments of type complex for an operation that is not found in the table for those types? For example, assume that we've defined a generic exponentiation operation:
+
+(define (exp x y) (apply-generic 'exp x y))
+
+;; and have put a procedure for exponentiation in the Scheme-number package but not in any other package:
+
+;; following added to Scheme-number package
+(put 'exp '(scheme-number scheme-number)
+ (lambda (x y) (tag (expt x y)))) ; using primitive expt
+
+;; What happens if we call exp with two complex numbers as arguments?
+
+;; the proper procedure will not be found, so apply-generic will look up the coercion procedure to coerce the first complex number to another complex number, then apply the procedure again. This will result in infinite recursion.
+
+;; b. Is Louis correct that something had to be done about coercion with arguments of the same type, or does apply-generic work correctly as is?
+
+;; No, Louis is wrong. Nothing needs to be done abotu coercion with arguments of the same type. His coercion procedures actually cause apply-generic to fail; apply-generic works correctly as-is.
+
+;; c. Modify apply-generic so that it doesn't try coercion if the two arguments have the same type.
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags)))
+ (if (equal? type1 type2)
+ (error "No method for these types"
+ (list op args))
+ (let ((a1 (car args))
+ (a2 (cadr args))
+ (t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond ((t1->t2 (apply-generic op (t1->t2 a1) a2))
+ (t2->t1 (apply-generic op a1 (t2->t1 a2)))
+ (else (error "No method for these types"
+ (list op args))))))))
+ (error "No method for these types"
+ (list op args))))))
+
+;; Exercise 2.82. Show how to generalize apply-generic to handle coercion in the general case of multiple arguments. One strategy is to attempt to coerce all the arguments to the type of the first argument, then to the type of the second argument, and so on. Give an example of a situation where this strategy (and likewise the two-argument version given above) is not sufficiently general. (Hint: Consider the case where there are some suitable mixed-type operations present in the table that will not be tried.)
blob - /dev/null
blob + 578832b2d3e974384c65d17b9fcf615695433895 (mode 644)
--- /dev/null
+++ ex2-82b-sol.scm
+(define (apply-generic op . args)
+ (define (try-convert x new-type)
+ (let ((converter (get-coercion (type-tag x) new-type)))
+ (if converter
+ (converter x)
+ x)))
+ (define (apply-generic-1 op args type-list)
+ (if (null? type-list)
+ (error "No method for these types"
+ (list op (map type-tag args)))
+ (let ((new-args (map (lambda (x)
+ (try-convert x (car type-list)))
+ args)))
+ (let ((new-type-tags (map type-tag new-args)))
+ (let ((proc (get op new-type-tags)))
+ (if proc
+ (apply proc (map contents new-args))
+ (apply-generic-1 op args (cdr type-list))))))))
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (apply-generic-1 op args type-tags)))))
blob - /dev/null
blob + 2aa8180dc1e814aa40a21540065f90f84b851094 (mode 644)
--- /dev/null
+++ ex2-83-sol.scm
+(define (coerce-to target-type remaining-args result)
+ (if (null? remaining-args)
+ result
+ (let* ((arg (car remaining-args))
+ (original-type (type-tag arg)))
+ (if (eq? original-type target-type)
+ (coerce-to target-type
+ (cdr remaining-args)
+ (append result (list arg)))
+ (let ((original->target (get-coercion (type-tag arg) target-type)))
+ (if original->target
+ (coerce-to target-type
+ (cdr remaining-args)
+ (append result (list (original->target arg))))
+ #f))))))
+(define (put-coercion source-type target-type proc)
+ (put 'coercion (list source-type target-type) proc))
+(define (get-coercion source-type target-type)
+ (get 'coercion (list source-type target-type)))
+
+(define (apply-generic-iter coercion-types)
+ (if (null? coercion-types)
+ (error "No method for these types, and could not coerce"
+ (list op (map type-tag args)))
+ (let ((coerced-args (coerce-to (car coercion-types) args '())))
+ (if coerced-args
+ (let ((proc (get op (map type-tag coerced-args))))
+ (if proc
+ (apply proc (map contents coerced-args))
+ (apply-generic-iter (cdr coercion-types))))
+ (apply-generic-iter (cdr coercion-types))))))
+(define (uniquify l)
+ (if (null? l)
+ '()
+ (let ((head (car l))
+ (tail (cdr l)))
+ (if (memq head tail)
+ (uniquify tail)
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (let ((unique-types (uniquify type-tags)))
+ (if (> (length unique-types) 1)
+ (apply-generic-iter unique-types)
+ (else (error "No method for this type"
+ (list op type-tags))))))))
+
+
+(define (attach-tag type-tag contents)
+ (if (number? contents)
+ contents
+ (cons type-tag contents)))
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error
+ "No method for these types -- APPLY-GENERIC"
+ (list op type-tags))))))
+(define (integer->rational n)
+ (make-rational n 1))
+(put 'raise '(integer)
+ (lambda (i) (integer->rational i)))
+(define (rational->real r)
+ (make-real
+ (exact->inexact (/ (numer r) (denom r)))))
+(put 'raise '(rational)
+ (lambda (r) (rational->real r)))
+(define (real->complex r)
+ (make-complex-from-real-imag r 0))
+(put 'raise '(real)
+ (lambda (r) (real->complex r)))
+(define (raise x)
+ (apply-generic 'raise x))
+
+(define (raise x) (apply-generic 'raise x))
+(put 'raise '(scheme-number)
+ (lambda (x)
+ (if (exact-integer? x)
+ (make-rational x 1)
+ (make-complex-from-real-imag x 0))))
+(put 'raise '(rational)
+ (lambda (r)
+ (make-scheme-number (exact->inexact (/ (numer r) (denom r))))))
+
+(define (install-integer-package)
+ (define (tag x)
+ (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (make-rational x y)))
+ (put 'equ '(integer integer) =)
+ (put '=zero? '(integer)
+ (lambda (x) (= 0 x)))
+ (put 'make 'integer
+ (lambda (x) (if (integer? x)
+ (tag x)
+ (error "non-integer value" x))))
+ 'done)
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+
+(define (install-real-package)
+ (define (tag x)
+ (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real)
+ (lambda (x) (= 0 x)))
+ (put 'make 'real
+ (lambda (x) (if (real? x)
+ (tag x)
+ (error "non-real value" x))))
+ 'done)
+
+(define (make-real n)
+ ((get 'make 'real) n))
+
+(define (install-rational-package)
+ (define (make-rat n d)
+ (if (and (integer? n) (integer? d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))
+ (error "non-integer numerator or denominator"
+ (list n d))))
+ 'done)
+
+(define (install-rectangular-package)
+ (define (make-from-real-imag x y)
+ (if (and (in-tower? x) (in-tower? y))
+ (cons x y)
+ (error "non-real real or imaginary value" (list x y))))
+ (define (make-from-mag-ang r a)
+ (if (and (real? r) (real? a))
+ (cons (* r (cos a)) (* r (sin a)))
+ (error "non-real magnitude or angle" (list r a))))
+
+ 'done)
+
+(define (install-polar-package)
+ (define (make-from-mag-ang r a)
+ (if (and (in-tower? r) (in-tower? a))
+ (cons r a)
+ (error "non-real magnitude or angle" (list r a))))
+ (define (make-from-real-imag x y)
+ (if (and (in-tower? x) (in-tower? y))
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x))
+ (error "non-real real or imaginary value" (list x y))))
+ 'done)
+
+(define (integer->rational i) (make-rational i 1))
+(define (rational->real r) (make-real (/ (numer r) (denom r))))
+(define (real->complex r) (make-complex-from-real-imag r 0))
+(define (raise x) (apply-generic 'raise x))
+
+(define tower-of-types '(integer rational real complex))
+(define (raise x)
+ (define (apply-raise types)
+ (cond ((null? types)
+ (error "Type not found in the tower-of-types"
+ (list x tower-of-types)))
+ ((eq? (type-tag x) (car types))
+ (if (null? (cdr types))
+ x
+ (let ((raiser (get-coercion (type-tag x) (cadr types))))
+ (if raiser
+ (raiser (contents x))
+ (error "No coercion procedure found for types"
+ (list (type-tag x) (cadr types)))))))
+ (else (apply-raise (cdr types)))))
+ (apply-raise tower-of-types))
+
+(define (install-integer-package)
+ (define (tag x)
+ (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (make-rational x y)))
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) =zero?)
+ (put 'make 'integer
+ (lambda (x) (if (integer? x)
+ (tag x)
+ (error "non-integer value" x))))
+ 'done)
+(define (make-integer n)
+ ((get 'make 'integer) n))
+
+(define (install-real-package)
+ (define (tag x)
+ (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real)
+ (lambda (x) (= 0 x)))
+ (put 'make 'real
+ (lambda (x) (if (real? x)
+ (tag x)
+ (error "non-real value" x))))
+
+(define (make-real n)
+ ((get 'make 'real) n))
+
+(define (install-rational-package)
+ (define (make-rat n d)
+ (if (and (integer? n) (integer? d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))
+ (error "non-integer numerator or denominator"
+ (list n d))))
+ 'done)
+
+(define (install-rectangular-package)
+ (define (make-from-real-imag x y)
+ (if (and (in-tower? x) (in-tower? y))
+ (cons x y)
+ (error "non-real real or imaginary value" (list x y))))
+ (define (make-from-mag-ang r a)
+ (if (and (real? r) (real? a))
+ (cons (* r (cos a)) (* r (sin a)))
+ (error "non-real magnitude or angle" (list r a))))
+ 'done)
+(define (install-polar-package)
+ (define (make-from-mag-ang r a)
+ (if (and (in-tower? r) (in-tower? a))
+ (cons r a)
+ (error "non-real magnitude or angle" (list r a))))
+ (define (make-from-real-imag x y)
+ (if (and (in-tower? x) (in-tower? y))
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x))
+ (error "non-real real or imaginary value" (list x y))))
+ 'done)
+
+
+(define (integer->rational i) (make-rational i 1))
+(define (rational->real r) (make-real (/ (numer r) (denom r))))
+(define (real->complex r) (make-complex-from-real-imag r 0))
+(define (raise x) (apply-generic 'raise x))
+
+(define tower-of-types '(integer rational real complex))
+(define (raise x)
+ (define (apply-raise types)
+ (cond ((null? types)
+ (error "Type not found in the tower-of-types"
+ (list x tower-of-types)))
+ ((eq? (type-tag x) (car types))
+ (if (null? (cdr types))
+ x
+ (let ((raiser (get-coercion (type-tag x) (cadr types))))
+ (if raiser
+ (raiser (contents x))
+ (error "No coercion procedure found for types"
+ (list (type-tag x) (cadr types)))))))
+ (else (apply-raise (cdr types)))))
+ (apply-raise tower-of-types))
+
+(define (integer->rational i) (make-rational i 1))
+(put-coercion 'integer 'rational integer->rational)
+'done
+(define (rational->real r) (make-real (/ (numer r) (denom r))))
+(put-coercion 'rational 'real rational->real)
+'done
+(define (real->complex r) (make-complex-from-real-imag r 0))
+(put-coercion 'real 'complex real->complex)
+'done
+
+
+(raise (make-integer 2))
+(raise (make-rational 3 4))
+(raise (
blob - /dev/null
blob + dbd0d3c99f5548636c6d2c218b7da0276988949e (mode 644)
--- /dev/null
+++ ex2-83-sol.scm~
+(define (coerce-to target-type remaining-args result)
+ (if (null? remaining-args)
+ result
+ (let* ((arg (car remaining-args))
+ (original-type (type-tag arg)))
+ (if (eq? original-type target-type)
+ (coerce-to target-type
+ (cdr remaining-args)
+ (append result (list arg)))
+ (let ((original->target (get-coercion (type-tag arg) target-type)))
+ (if original->target
+ (coerce-to target-type
+ (cdr remaining-args)
+ (append result (list (original->target arg))))
+ #f))))))
+(define (put-coercion source-type target-type proc)
+ (put 'coercion (list source-type target-type) proc))
+(define (get-coercion source-type target-type)
+ (get 'coercion (list source-type target-type)))
+
+(define (apply-generic-iter coercion-types)
+ (if (null? coercion-types)
+ (error "No method for these types, and could not coerce"
+ (list op (map type-tag args)))
+ (let ((coerced-args (coerce-to (car coercion-types) args '())))
+ (if coerced-args
+ (let ((proc (get op (map type-tag coerced-args))))
+ (if proc
+ (apply proc (map contents coerced-args))
+ (apply-generic-iter (cdr coercion-types))))
+ (apply-generic-iter (cdr coercion-types))))))
+(define (uniquify l)
+ (if (null? l)
+ '()
+ (let ((head (car l))
+ (tail (cdr l)))
+ (if (memq head tail)
+ (uniquify tail)
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (let ((unique-types (uniquify type-tags)))
+ (if (> (length unique-types) 1)
+ (apply-generic-iter unique-types)
+ (else (error "No method for this type"
+ (list op type-tags))))))))
+
+
+(define (attach-tag type-tag contents)
+ (if (number? contents)
+ contents
+ (cons type-tag contents)))
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (error
+ "No method for these types -- APPLY-GENERIC"
+ (list op type-tags))))))
+(define (integer->rational n)
+ (make-rational n 1))
+(put 'raise '(integer)
+ (lambda (i) (integer->rational i)))
+(define (rational->real r)
+ (make-real
+ (exact->inexact (/ (numer r) (denom r)))))
+(put 'raise '(rational)
+ (lambda (r) (rational->real r)))
+(define (real->complex r)
+ (make-complex-from-real-imag r 0))
+(put 'raise '(real)
+ (lambda (r) (real->complex r)))
+(define (raise x)
+ (apply-generic 'raise x))
+
+(define (raise x) (apply-generic 'raise x))
+(put 'raise '(scheme-number)
+ (lambda (x)
+ (if (exact-integer? x)
+ (make-rational x 1)
+ (make-complex-from-real-imag x 0))))
+(put 'raise '(rational)
+ (lambda (r)
+ (make-scheme-number (exact->inexact (/ (numer r) (denom r))))))
+
+(define (install-integer-package)
+ (define (tag x)
+ (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (make-rational x y)))
+ (put 'equ '(integer integer) =)
+ (put '=zero? '(integer)
+ (lambda (x) (= 0 x)))
+ (put 'make 'integer
+ (lambda (x) (if (integer? x)
+ (tag x)
+ (error "non-integer value" x))))
+ 'done)
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+
+(define (install-real-package)
+ (define (tag x)
+ (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real)
+ (lambda (x) (= 0 x)))
+ (put 'make 'real
+ (lambda (x) (if (real? x)
+ (tag x)
+ (error "non-real value" x))))
+ 'done)
+
+(define (make-real n)
+ ((get 'make 'real) n))
+
+(define (install-rational-package)
+ (define (make-rat n d)
+ (if (and (integer? n) (integer? d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))
+ (error "non-integer numerator or denominator"
+ (list n d))))
+ 'done)
+
+(define (install-rectangular-package)
+ (define (make-from-real-imag x y)
+ (if (and (in-tower? x) (in-tower? y))
+ (cons x y)
+ (error "non-real real or imaginary value" (list x y))))
+ (define (make-from-mag-ang r a)
+ (if (and (real? r) (real? a))
+ (cons (* r (cos a)) (* r (sin a)))
+ (error "non-real magnitude or angle" (list r a))))
+
+ 'done)
+
+(define (install-polar-package)
+ (define (make-from-mag-ang r a)
+ (if (and (in-tower? r) (in-tower? a))
+ (cons r a)
+ (error "non-real magnitude or angle" (list r a))))
+ (define (make-from-real-imag x y)
+ (if (and (in-tower? x) (in-tower? y))
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x))
+ (error "non-real real or imaginary value" (list x y))))
+ 'done)
+
+(define (integer->rational i) (make-rational i 1))
+(define (rational->real r) (make-real (/ (numer r) (denom r))))
+(define (real->complex r) (make-complex-from-real-imag r 0))
+(define (raise x) (apply-generic 'raise x))
+
+(define tower-of-types '(integer rational real complex))
+(define (raise x)
+ (define (apply-raise types)
+ (cond ((null? types)
+ (error "Type not found in the tower-of-types"
+ (list x tower-of-types)))
+ ((eq? (type-tag x) (car types))
+ (if (null? (cdr types))
+ x
+ (let ((raiser (get-coercion (type-tag x) (cadr types))))
+ (if raiser
+ (raiser (contents x))
+ (error "No coercion procedure found for types"
+ (list (type-tag x) (cadr types)))))))
+ (else (apply-raise (cdr types)))))
+ (apply-raise tower-of-types))
+
blob - /dev/null
blob + 40c830477454c983250b19e2e7187b83ecf0f186 (mode 644)
--- /dev/null
+++ ex2-83.scm
+;; Exercise 2.83. Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex).
+
+;; we have to modify our packages so that we have 4 types: integer, rational, real, and complex
+
+(define (attach-tag type-tag contents)
+ (if (or (eq? type-tag 'integer)
+ (eq? type-tag 'real))
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((pair? datum) (car datum))
+ ((exact? datum) 'integer)
+ ((number? datum) 'real)
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((pair? datum) (cdr datum))
+ ((exact? datum) datum)
+ ((number? datum) (exact->inexact datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+(define coercion-table (make-table))
+(define get-coercion (coercion-table 'lookup-proc))
+(define put-coercion (coercion-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+(define (raise x) (apply-generic 'raise x))
+
+(define (install-integer-package)
+ (define (tag x) (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (quotient x y))))
+ ;; (if (integer? (/ x y))
+ ;; (tag (/ x y))
+ ;; (div (raise (tag x))
+ ;; (raise (tag y))))))
+ ;; ;; we avoided calling make-rational to avoid dependencies
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) zero?)
+ (put 'make 'integer
+ (lambda (n)
+ (if (exact? n)
+ (tag n)
+ (error "Not an exact integer" n))))
+ (put 'raise '(integer)
+ (lambda (x) (make-rational x 1)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (if (not (and (integer? n) (integer? d)))
+ (error "Both numerator and denominator must be integers"
+ (list n d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'raise '(rational)
+ (lambda (x) (make-real (/ (numer x) (denom x)))))
+
+ 'done)
+
+(define (install-real-package)
+ (define (tag x) (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real) zero?)
+ (put 'make 'real
+ (lambda (n)
+ (if (rational? n)
+ (tag (exact->inexact n))
+ (tag n))))
+ (put 'raise '(real)
+ (lambda (x) (make-complex-from-real-imag x 0)))
+
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-real n)
+ ((get 'make 'real) n))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args)))
+ (let ((t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond (t1->t2
+ (apply-generic op (t1->t2 a1) a2))
+ (t2->t1
+ (apply-generic op a1 (t2->t1 a2)))
+ (else
+ (error "No method for these types"
+ (list op type-tags))))))
+ (error "No method for these types"
+ (list op type-tags)))))))
+
+;; install number packages
+
+(install-integer-package)
+(install-rational-package)
+(install-real-package)
+(install-complex-package)
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (equ? (add (make-integer 3) (make-integer 4))
+ (sub (make-integer 12) (make-integer 5))) #t)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3))) #t)
+(test-case (equ? (add (make-integer 3) (make-integer 3))
+ (sub (make-integer 12) (make-integer 5))) #f)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 2))) #f)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3)))) #t)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 4)))) #f)
+(test-case (make-integer 5) 5)
+(test-case (type-tag (make-integer 5)) 'integer)
+(test-case (type-tag (make-real 5)) 'real)
+(test-case (make-real 1.66667) 1.66667)
+(test-case (make-real (/ 5 3)) 1.66667)
+(test-case (type-tag (make-real (/ 5 3))) 'real)
+
+(test-case (div (make-integer 3) (make-integer 4)) 0)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6))))) #t)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 5))))) #f)
+(test-case (equ? (add (make-rational 7 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6)))) #t)
+(test-case (equ? (add (make-rational 3 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 1 6)))) #f)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))) #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 5)))) #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+(test-case (raise (make-integer 5)) '(rational 5 . 1))
+(test-case (raise (raise (make-integer 5))) 5.)
+(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0))
+
+(test-case (raise (make-rational 5 3)) 1.666667)
+(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0))
+
+
+
+
blob - /dev/null
blob + cef090df6e8ff1b1d051a7a051bc3d6aa5d03e8c (mode 644)
--- /dev/null
+++ ex2-83.scm~
+;; Exercise 2.83. Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex).
+
+;; we have to modify our packages so that we have 4 types: integer, rational, real, and complex
+
+(define (attach-tag type-tag contents)
+ (if (or (eq? type-tag 'integer)
+ (eq? type-tag 'real))
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((integer? datum) 'integer)
+ ((number? datum) 'real)
+ ((pair? datum) (car datum))
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((integer? datum) datum)
+ ((number? datum) (exact->inexact datum))
+ ((pair? datum) (cdr datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+(define coercion-table (make-table))
+(define get-coercion (coercion-table 'lookup-proc))
+(define put-coercion (coercion-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+
+(define (install-integer-package)
+ (define (tag x) (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (quotient x y))))
+ ;; (if (integer? (/ x y))
+ ;; (tag (/ x y))
+ ;; (div (raise (tag x))
+ ;; (raise (tag y))))))
+ ;; ;; we avoided calling make-rational to avoid dependencies
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) zero?)
+ (put 'make 'integer
+ (lambda (n)
+ (if (integer? n)
+ (tag n)
+ (error "Not an integer" n))))
+ (put 'raise 'integer
+ (lambda (x) (make-rational x 1)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (if (not (and (integer? n) (integer? d)))
+ (error "Both numerator and denominator must be integers"
+ (list n d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'raise 'rational
+ (lambda (x) (make-real (/ (numer x) (denom x)))))
+
+ 'done)
+
+(define (install-real-package)
+ (define (tag x) (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real) zero?)
+ (put 'make 'real
+ (lambda (n)
+ (if (integer? n)
+ (tag (exact->inexact n))
+ (tag n))))
+(put 'raise 'real (lambda (x) (make-complex-from-real-imag x 0)))
+
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-real n)
+ ((get 'make 'real) n))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+
+;; install number packages
+
+(install-integer-package)
+(install-rational-package)
+(install-real-package)
+(install-complex-package)
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (equ? (add (make-integer 3) (make-integer 4))
+ (sub (make-integer 12) (make-integer 5))) #t)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3))) #t)
+(test-case (equ? (add (make-integer 3) (make-integer 3))
+ (sub (make-integer 12) (make-integer 5))) #f)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 2))) #f)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3)))) #t)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 4)))) #f)
+(test-case (make-integer 5) 5)
+(test-case (type-tag (make-integer 5)) 'integer)
+(test-case (type-tag (make-real 5)) 'integer) ;; automatically drops
+(test-case (make-real 1.66667) 1.66667)
+;; (test-case (make-real (/ 5 3)) 1.66667) fails
+
+(test-case (div (make-integer 3) (make-integer 4)) 0)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6))))) #t)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 5))))) #f)
+(test-case (equ? (add (make-rational 7 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6)))) #t)
+(test-case (equ? (add (make-rational 3 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 1 6)))) #f)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))) #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 5)))) #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+;; (test-case (=zero? (sub (div (make-rational 4 3)
+;; (make-rational 1 3))
+;; (sub (make-rational 9 1)
+;; (mul (make-rational 4 1)
+;; (make-rational 3 4)))))
+;; #f)
+;; (test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+;; (make-complex-from-real-imag -5 -3))
+;; '(complex rectangular -2 . 1)))
+;; #f)
+
+;; (define (scheme-number->complex n)
+;; (make-complex-from-real-imag (contents n) 0))
+;; (put-coercion 'scheme-number 'complex scheme-number->complex)
+
+(define (apply-generic op . args)
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((type1 (car type-tags))
+ (type2 (cadr type-tags))
+ (a1 (car args))
+ (a2 (cadr args)))
+ (let ((t1->t2 (get-coercion type1 type2))
+ (t2->t1 (get-coercion type2 type1)))
+ (cond (t1->t2
+ (apply-generic op (t1->t2 a1) a2))
+ (t2->t1
+ (apply-generic op a1 (t2->t1 a2)))
+ (else
+ (error "No method for these types"
+ (list op type-tags))))))
+ (error "No method for these types"
+ (list op type-tags)))))))
+
+
+;; (test-case (add (make-scheme-number 5)
+;; (make-complex-from-real-imag 3 2))
+;; '(complex rectangular 8 . 2))
+;; (test-case (add (make-complex-from-mag-ang 5 0.927295218)
+;; (make-scheme-number 2))
+;; '(complex rectangular 5 . 4))
+
+
+(define (raise x) (apply-generic 'raise x))
+
blob - /dev/null
blob + 286164bf9dddfba9a32887c7035dd28e299c1853 (mode 644)
--- /dev/null
+++ ex2-84-sol.scm
+(define (find-highest-type l)
+ (define (filter-type t f)
+ (cond ((null? f) '())
+ ((eq? (car f) t) (filter-type t (cdr f)))
+ (else (cons (car f) (filter-type t (cdr f))))))
+ (define (find-highest highest remaining-tower remaining-list)
+ (cond ((null? remaining-list) highest)
+ ((null? remaining-tower)
+ (error "Cannot find highest type from non-tower types -- FIND-HIGHEST-TYPE"
+ remaining-list))
+ (else (find-highest (car remaining-tower)
+ (cdr remaining-tower)
+ (filter-type (car remaining-tower) remaining-list)))))
+ (find-highest #f tower-of-types l))
+
+(find-highest-type '(integer real rational real))
+(find-highest-type '(rational rational rational))
+(find-highest-type '(complex real rational integer))
+(find-highest-type '())
+(find-highest-type '(integer wibble real wobble complex))
+
+(define (raise-to type value)
+ (cond ((eq? type (type-tag value)) value)
+ ((memq type tower-of-types) (raise-to type (raise value)))
+ (else (error "Cannot raise to non-tower type -- RAISE-TO"
+ (list type tower-of-types)))))
+(raise-to 'real (make-integer 4))
+(raise-to 'complex (make-rational 3 4))
+(raise-to 'real (make-real 3.14159))
+(raise-to 'wibble (make-integer 42))
+
+(define (raise-all-to type values)
+ (if (null? values)
+ '()
+ (cons (raise-to-type (car values)) (raise-all-to type (cdr values)))))
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (> (length args) 1)
+ (let* ((highest-type (find-highest-type type-tags))
+ (mapped-args (raise-all-to highest-type args))
+ (mapped-types (map type-tag mapped-args))
+ (mapped-proc (get op mapped-types)))
+ (if mapped-proc
+ (apply mapped-proc (map contents mapped-args))
+ (error
+ "No method for these types -- APPLY-GENERIC"
+ (list op type-tags))))))))
+(put 'addd '(integer integer integer)
+ (lambda (x y z) (tag (+ x y z))))
+(define (addd x y z)
+ (make-rat (+ (* (numer x) (denom y) (denom z))
+ (* (denom x) (numer y) (denom z))
+ (* (denom x) (denom y) (numer z)))
+ (* (denom x) (denom y) (denom z))))
+(put 'addd '(rational rational rational)
+ (lambda (x y z) (tag (addd x y z))))
+(put 'add '(real real real)
+ (lambda (x y z) (tag (+ x y z))))
+(addd (make-real 3.14159) (make-rational 3 4) (make-complex-from-real-imag 1 7))
+
+(define (raise x) (apply-generic 'raise x))
+(put 'raise '(scheme-number)
+ (lambda (x)
+ (if (exact-integer? x)
+ (make-rational x 1)
+ (make-complex-from-real-imag x 0))))
+(put 'raise '(rational)
+ (lambda (r)
+ (make-scheme-number (exact->inexact (/ (numer r) (denom r))))))
+
+(define (tower-level x)
+ (let ((typex (type-tag x)))
+ (cond ((eq? typex 'rational) 1)
+ ((eq? typex 'complex) 3)
+ (else
+ (let ((y (contents x)))
+ (if (exact-integer? y)
+ 0
+ 2))))))
+(define (raise-to level x)
+ (if (= level (tower-level x))
+ x
+ (raise-to level (raise x))))
+
+(define (apply-generic op . args)
+ (let ((typetags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let* ((a1 (car args))
+ (a2 (cadr args))
+ (level1 (tower-level a1))
+ (level2 (tower-level a2)))
+ (cond ((< level1 level2)
+ (apply-generic op (raise-to level2 a1) a2))
+ ((< level2 level1)
+ (apply-generic op a1 (raise-to level1 a2)))
+ (else
+ (error "No method for these types"
+ (list op type-tags)))))
+ (error "No method for these types"
+ (lsit op type-tags)))))))
+
+(define (apply-generic-r op . args)
+ (define (no-method type-tags)
+ (error "No method for these types"
+ (list op type-tags)))
+ (define (raise-into s t)
+ (let ((s-type (type-tag s))
+ (t-type (type-tag t)))
+ (cond ((equal? s-type t-type) s)
+ ((get 'raise (list s-type))
+ (raise-into ((get 'raise (list s-type)) (contents s)) t))
+ (t #f))))
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((o1 (car args))
+ (o2 (cadr args)))
+ (cond
+ ((raise-into o1 o2)
+ (apply-generic-r op (raise-into o1 o2) o2))
+ ((raise-into o2 o1)
+ (apply-generic-r op o2 (raise-into o2 o1)))
+ (t (no-method type-tags))))
+ (no-method type-tags))))))
blob - /dev/null
blob + 52f2735a0097040b10efffe684ea5facfd190c91 (mode 644)
--- /dev/null
+++ ex2-84-sol.scm~
+(define (find-highest-type l)
+ (define (filter-type t f)
+ (cond ((null? f)
blob - /dev/null
blob + 8edc8350eaaf52ff24fa960a8c982faff9893c20 (mode 644)
--- /dev/null
+++ ex2-84.scm
+;; Exercise 2.83. Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex).
+
+;; we have to modify our packages so that we have 4 types: integer, rational, real, and complex
+
+(define (attach-tag type-tag contents)
+ (if (or (eq? type-tag 'integer)
+ (eq? type-tag 'real))
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((pair? datum) (car datum))
+ ((exact? datum) 'integer)
+ ((number? datum) 'real)
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((pair? datum) (cdr datum))
+ ((exact? datum) datum)
+ ((number? datum) (exact->inexact datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+;; (define coercion-table (make-table))
+;; (define get-coercion (coercion-table 'lookup-proc))
+;; (define put-coercion (coercion-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+(define (raise x) (apply-generic 'raise x))
+
+(define (install-integer-package)
+ (define (tag x) (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (quotient x y))))
+ ;; (if (integer? (/ x y))
+ ;; (tag (/ x y))
+ ;; (div (raise (tag x))
+ ;; (raise (tag y))))))
+ ;; ;; we avoided calling make-rational to avoid dependencies
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) zero?)
+ (put 'make 'integer
+ (lambda (n)
+ (if (exact? n)
+ (tag n)
+ (error "Not an exact integer" n))))
+ (put 'raise '(integer)
+ (lambda (x) (make-rational x 1)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (if (not (and (integer? n) (integer? d)))
+ (error "Both numerator and denominator must be integers"
+ (list n d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'raise '(rational)
+ (lambda (x) (make-real (/ (numer x) (denom x)))))
+
+ 'done)
+
+(define (install-real-package)
+ (define (tag x) (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real) zero?)
+ (put 'make 'real
+ (lambda (n)
+ (if (rational? n)
+ (tag (exact->inexact n))
+ (tag n))))
+ (put 'raise '(real)
+ (lambda (x) (make-complex-from-real-imag x 0)))
+
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (install-polynomial-package)
+ (define (tag x) (attach-tag 'polynomial x))
+ 'done)
+
+
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-real n)
+ ((get 'make 'real) n))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; (define (apply-generic op . args)
+;; (let ((type-tags (map type-tag args)))
+;; (let ((proc (get op type-tags)))
+;; (if proc
+;; (apply proc (map contents args))
+;; (if (= (length args) 2)
+;; (let ((type1 (car type-tags))
+;; (type2 (cadr type-tags))
+;; (a1 (car args))
+;; (a2 (cadr args)))
+;; (let ((t1->t2 (get-coercion type1 type2))
+;; (t2->t1 (get-coercion type2 type1)))
+;; (cond (t1->t2
+;; (apply-generic op (t1->t2 a1) a2))
+;; (t2->t1
+;; (apply-generic op a1 (t2->t1 a2)))
+;; (else
+;; (error "No method for these types"
+;; (list op type-tags))))))
+;; (error "No method for these types"
+;; (list op type-tags)))))))
+
+;; install number packages
+
+(install-integer-package)
+(install-rational-package)
+(install-real-package)
+(install-complex-package)
+(install-polynomial-package)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (equ? (add (make-integer 3) (make-integer 4))
+ (sub (make-integer 12) (make-integer 5))) #t)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3))) #t)
+(test-case (equ? (add (make-integer 3) (make-integer 3))
+ (sub (make-integer 12) (make-integer 5))) #f)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 2))) #f)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3)))) #t)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 4)))) #f)
+(test-case (make-integer 5) 5)
+(test-case (type-tag (make-integer 5)) 'integer)
+(test-case (type-tag (make-real 5)) 'real)
+(test-case (make-real 1.66667) 1.66667)
+(test-case (make-real (/ 5 3)) 1.66667)
+(test-case (type-tag (make-real (/ 5 3))) 'real)
+
+(test-case (div (make-integer 3) (make-integer 4)) 0)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6))))) #t)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 5))))) #f)
+(test-case (equ? (add (make-rational 7 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6)))) #t)
+(test-case (equ? (add (make-rational 3 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 1 6)))) #f)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))) #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 5)))) #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+(test-case (raise (make-integer 5)) '(rational 5 . 1))
+(test-case (raise (raise (make-integer 5))) 5.)
+(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0))
+
+(test-case (raise (make-rational 5 3)) 1.666667)
+(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0))
+
+;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower.
+
+;; (define (raise-to-second-type arg1 arg2)
+;; (if (eq? (type-tag arg1) (type-tag arg2))
+;; (cons arg1 arg2)
+;; (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+;; (if raise-proc
+;; (raise-to-second-type (raise-proc (contents arg1)) arg2)
+;; #f))))
+
+;; (test-case (raise-to-second-type (make-integer 5)
+;; (make-complex-from-real-imag 4 6))
+;; '((complex rectangular 5 . 0) . (complex rectangular 4 . 6)))
+;; (test-case (raise-to-second-type (make-complex-from-mag-ang 4 3)
+;; (make-complex-from-real-imag 2 3))
+;; '((complex polar 4 . 3) . (complex rectangular 2 . 3)))
+;; (test-case (raise-to-second-type (make-rational 5 3)
+;; (make-integer 2))
+;; #f)
+;; (test-case (raise-to-second-type (make-complex-from-mag-ang 5 3)
+;; (make-rational 2 6))
+;; #f)
+;; (test-case (raise-to-second-type (make-rational 4 2)
+;; (make-real 4.5))
+;; '(2. . 4.5))
+
+;; (define (apply-generic op . args)
+;; ;; return arg1 raised to same type as arg2, #f if not possible
+;; (define (raise-to-second-type arg1 arg2)
+;; (if (eq? (type-tag arg1) (type-tag arg2))
+;; (cons arg1 arg2)
+;; (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+;; (if raise-proc
+;; (raise-to-second-type (raise-proc (contents arg1)) arg2)
+;; #f))))
+;; (let* ((type-tags (map type-tag args))
+;; (proc (get op type-tags)))
+;; (if proc
+;; (apply proc (map contents args))
+;; (if (= (length args) 2)
+;; (let ((a1 (car args))
+;; (a2 (cadr args)))
+;; (if (eq? (type-tag a1) (type-tag a2))
+;; (error "No method for these common types" (list op type-tags))
+;; (let ((raised-pair (or (raise-to-second-type a1 a2)
+;; (raise-to-second-type a2 a1))))
+;; (if raised-pair
+;; (let ((raised1 (car raised-pair))
+;; (raised2 (cdr raised-pair)))
+;; (apply-generic op raised1 raised2))
+;; (error "No common supertype"
+;; (list op type-tags)))))) ;; error messages may not be accurate
+;; (error "No method for these (≠2) types"
+;; (list op type-tags))))) ;; error messages may not be accurate
+
+(test-case (add (make-integer 5) (make-rational 3 1))
+ (make-rational 8 1))
+(test-case (div (make-integer 2) (make-real 5))
+ 0.4)
+(test-case (mul (make-complex-from-real-imag 3 4)
+ (make-integer 2))
+ ...)
+
blob - /dev/null
blob + 8edc8350eaaf52ff24fa960a8c982faff9893c20 (mode 644)
--- /dev/null
+++ ex2-84.scm~
+;; Exercise 2.83. Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex).
+
+;; we have to modify our packages so that we have 4 types: integer, rational, real, and complex
+
+(define (attach-tag type-tag contents)
+ (if (or (eq? type-tag 'integer)
+ (eq? type-tag 'real))
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((pair? datum) (car datum))
+ ((exact? datum) 'integer)
+ ((number? datum) 'real)
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((pair? datum) (cdr datum))
+ ((exact? datum) datum)
+ ((number? datum) (exact->inexact datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+;; (define coercion-table (make-table))
+;; (define get-coercion (coercion-table 'lookup-proc))
+;; (define put-coercion (coercion-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+(define (raise x) (apply-generic 'raise x))
+
+(define (install-integer-package)
+ (define (tag x) (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (quotient x y))))
+ ;; (if (integer? (/ x y))
+ ;; (tag (/ x y))
+ ;; (div (raise (tag x))
+ ;; (raise (tag y))))))
+ ;; ;; we avoided calling make-rational to avoid dependencies
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) zero?)
+ (put 'make 'integer
+ (lambda (n)
+ (if (exact? n)
+ (tag n)
+ (error "Not an exact integer" n))))
+ (put 'raise '(integer)
+ (lambda (x) (make-rational x 1)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (if (not (and (integer? n) (integer? d)))
+ (error "Both numerator and denominator must be integers"
+ (list n d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'raise '(rational)
+ (lambda (x) (make-real (/ (numer x) (denom x)))))
+
+ 'done)
+
+(define (install-real-package)
+ (define (tag x) (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real) zero?)
+ (put 'make 'real
+ (lambda (n)
+ (if (rational? n)
+ (tag (exact->inexact n))
+ (tag n))))
+ (put 'raise '(real)
+ (lambda (x) (make-complex-from-real-imag x 0)))
+
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (install-polynomial-package)
+ (define (tag x) (attach-tag 'polynomial x))
+ 'done)
+
+
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-real n)
+ ((get 'make 'real) n))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; (define (apply-generic op . args)
+;; (let ((type-tags (map type-tag args)))
+;; (let ((proc (get op type-tags)))
+;; (if proc
+;; (apply proc (map contents args))
+;; (if (= (length args) 2)
+;; (let ((type1 (car type-tags))
+;; (type2 (cadr type-tags))
+;; (a1 (car args))
+;; (a2 (cadr args)))
+;; (let ((t1->t2 (get-coercion type1 type2))
+;; (t2->t1 (get-coercion type2 type1)))
+;; (cond (t1->t2
+;; (apply-generic op (t1->t2 a1) a2))
+;; (t2->t1
+;; (apply-generic op a1 (t2->t1 a2)))
+;; (else
+;; (error "No method for these types"
+;; (list op type-tags))))))
+;; (error "No method for these types"
+;; (list op type-tags)))))))
+
+;; install number packages
+
+(install-integer-package)
+(install-rational-package)
+(install-real-package)
+(install-complex-package)
+(install-polynomial-package)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (equ? (add (make-integer 3) (make-integer 4))
+ (sub (make-integer 12) (make-integer 5))) #t)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3))) #t)
+(test-case (equ? (add (make-integer 3) (make-integer 3))
+ (sub (make-integer 12) (make-integer 5))) #f)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 2))) #f)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3)))) #t)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 4)))) #f)
+(test-case (make-integer 5) 5)
+(test-case (type-tag (make-integer 5)) 'integer)
+(test-case (type-tag (make-real 5)) 'real)
+(test-case (make-real 1.66667) 1.66667)
+(test-case (make-real (/ 5 3)) 1.66667)
+(test-case (type-tag (make-real (/ 5 3))) 'real)
+
+(test-case (div (make-integer 3) (make-integer 4)) 0)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6))))) #t)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 5))))) #f)
+(test-case (equ? (add (make-rational 7 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6)))) #t)
+(test-case (equ? (add (make-rational 3 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 1 6)))) #f)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))) #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 5)))) #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+(test-case (raise (make-integer 5)) '(rational 5 . 1))
+(test-case (raise (raise (make-integer 5))) 5.)
+(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0))
+
+(test-case (raise (make-rational 5 3)) 1.666667)
+(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0))
+
+;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower.
+
+;; (define (raise-to-second-type arg1 arg2)
+;; (if (eq? (type-tag arg1) (type-tag arg2))
+;; (cons arg1 arg2)
+;; (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+;; (if raise-proc
+;; (raise-to-second-type (raise-proc (contents arg1)) arg2)
+;; #f))))
+
+;; (test-case (raise-to-second-type (make-integer 5)
+;; (make-complex-from-real-imag 4 6))
+;; '((complex rectangular 5 . 0) . (complex rectangular 4 . 6)))
+;; (test-case (raise-to-second-type (make-complex-from-mag-ang 4 3)
+;; (make-complex-from-real-imag 2 3))
+;; '((complex polar 4 . 3) . (complex rectangular 2 . 3)))
+;; (test-case (raise-to-second-type (make-rational 5 3)
+;; (make-integer 2))
+;; #f)
+;; (test-case (raise-to-second-type (make-complex-from-mag-ang 5 3)
+;; (make-rational 2 6))
+;; #f)
+;; (test-case (raise-to-second-type (make-rational 4 2)
+;; (make-real 4.5))
+;; '(2. . 4.5))
+
+;; (define (apply-generic op . args)
+;; ;; return arg1 raised to same type as arg2, #f if not possible
+;; (define (raise-to-second-type arg1 arg2)
+;; (if (eq? (type-tag arg1) (type-tag arg2))
+;; (cons arg1 arg2)
+;; (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+;; (if raise-proc
+;; (raise-to-second-type (raise-proc (contents arg1)) arg2)
+;; #f))))
+;; (let* ((type-tags (map type-tag args))
+;; (proc (get op type-tags)))
+;; (if proc
+;; (apply proc (map contents args))
+;; (if (= (length args) 2)
+;; (let ((a1 (car args))
+;; (a2 (cadr args)))
+;; (if (eq? (type-tag a1) (type-tag a2))
+;; (error "No method for these common types" (list op type-tags))
+;; (let ((raised-pair (or (raise-to-second-type a1 a2)
+;; (raise-to-second-type a2 a1))))
+;; (if raised-pair
+;; (let ((raised1 (car raised-pair))
+;; (raised2 (cdr raised-pair)))
+;; (apply-generic op raised1 raised2))
+;; (error "No common supertype"
+;; (list op type-tags)))))) ;; error messages may not be accurate
+;; (error "No method for these (≠2) types"
+;; (list op type-tags))))) ;; error messages may not be accurate
+
+(test-case (add (make-integer 5) (make-rational 3 1))
+ (make-rational 8 1))
+(test-case (div (make-integer 2) (make-real 5))
+ 0.4)
+(test-case (mul (make-complex-from-real-imag 3 4)
+ (make-integer 2))
+ ...)
+
blob - /dev/null
blob + 2285530eed2a714a0c0dd7c41898d399fe6a9e92 (mode 644)
--- /dev/null
+++ ex2-84b.scm
+(define (attach-tag type-tag contents)
+ (if (or (eq? type-tag 'integer)
+ (eq? type-tag 'real))
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((pair? datum) (car datum))
+ ((exact? datum) 'integer)
+ ((number? datum) 'real)
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((pair? datum) (cdr datum))
+ ((exact? datum) datum)
+ ((number? datum) (exact->inexact datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+(define (raise x) (apply-generic 'raise x))
+
+(define (install-integer-package)
+ (define (tag x) (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (quotient x y))))
+ ;; (if (integer? (/ x y))
+ ;; (tag (/ x y))
+ ;; (div (raise (tag x))
+ ;; (raise (tag y))))))
+ ;; ;; we avoided calling make-rational to avoid dependencies
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) zero?)
+ (put 'make 'integer
+ (lambda (n)
+ (if (exact? n)
+ (tag n)
+ (error "Not an exact integer" n))))
+ (put 'raise '(integer)
+ (lambda (x) (make-rational x 1)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (if (not (and (integer? n) (integer? d)))
+ (error "Both numerator and denominator must be integers"
+ (list n d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'raise '(rational)
+ (lambda (x) (make-real (/ (numer x) (denom x)))))
+
+ 'done)
+
+(define (install-real-package)
+ (define (tag x) (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real) zero?)
+ (put 'make 'real
+ (lambda (n)
+ (if (rational? n)
+ (tag (exact->inexact n))
+ (tag n))))
+ (put 'raise '(real)
+ (lambda (x) (make-complex-from-real-imag x 0)))
+
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (install-polynomial-package)
+ (define (tag x) (attach-tag 'polynomial x))
+ 'done)
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-real n)
+ ((get 'make 'real) n))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; install number packages
+
+(install-integer-package)
+(install-rational-package)
+(install-real-package)
+(install-complex-package)
+(install-polynomial-package)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower.
+
+;; (define (raise-to-second-type arg1 arg2)
+;; (if (eq? (type-tag arg1) (type-tag arg2))
+;; arg1
+;; (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+;; (if raise-proc
+;; (raise-to-second-type (raise-proc (contents arg1)) arg2)
+;; #f))))
+
+;; (test-case (raise-to-second-type (make-integer 5)
+;; (make-complex-from-real-imag 4 6))
+;; '(complex rectangular 5. . 0))
+;; (test-case (raise-to-second-type (make-complex-from-mag-ang 4 3)
+;; (make-complex-from-real-imag 2 3))
+;; '(complex polar 4 . 3)) ;; should there be a decimal point after 4 and 3?
+;; (test-case (raise-to-second-type (make-rational 5 3)
+;; (make-integer 2))
+;; #f)
+;; (test-case (raise-to-second-type (make-complex-from-mag-ang 5 3)
+;; (make-rational 2 6))
+;; #f)
+;; (test-case (raise-to-second-type (make-rational 4 2)
+;; (make-real 4.5))
+;; 2.)
+
+;; not going to call apply-generic recursively so we can get more informative error messages
+;; we could have apply-generic return #f if a procedure isn't found. This could help us avoid a helper function like raise-to-second-type, and we could then just raise recursively, but then we'd lose the error messages.
+
+(define (apply-generic op . args)
+ ;; return arg1 raised to same type as arg2, #f if not possible
+ (define (raise-to-second-type arg1 arg2)
+ (if (eq? (type-tag arg1) (type-tag arg2))
+ arg1
+ (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+ (if raise-proc
+ (raise-to-second-type (raise-proc (contents arg1)) arg2)
+ #f))))
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((a1 (car args))
+ (a2 (cadr args)))
+ (if (eq? (type-tag a1) (type-tag a2))
+ (list "No method for these common types" (list op type-tags))
+ (let ((raised1 (raise-to-second-type a1 a2))
+ (raised2 (raise-to-second-type a2 a1)))
+ (cond (raised1
+ (let ((proc (get op (list (type-tag raised1) (type-tag a2)))))
+ (if proc
+ (apply-generic proc raised1 a2)
+ (list "No procedure, even after raising first argument"
+ (list op type-tags)))))
+ (raised2
+ (let ((proc (get op (list a1 (type-tag raised2)))))
+ (if proc
+ (apply-generic proc a1 raised2)
+ (list "No procedure, even after raising second argument"
+ (list op type-tags)))))
+ (else (list "No common supertype" (list op type-tags)))))))))))
+
+
+
+;; (test-case (add (make-integer 4) '(nonsense-type . 3))
+;; '("No common supertype" (add (integer nonsense-type))))
+;; (test-case (apply-generic 'dummy (make-integer 3) (make-real 4.))
+;; '("No procedure, even after raising first argument" (dummy (integer real))))
+;; (test-case (apply-generic 'dummy (make-real 4.) (make-integer 3))
+;; '("No procedure, even after raising second argument" (dummy (real integer))))
+
+
+;; (test-case (add (make-integer 5) (make-rational 3 1))
+;; (make-rational 8 1))
+;; (test-case (div (make-integer 2) (make-real 5))
+;; 0.4)
+;; (test-case (mul (make-complex-from-real-imag 3 4)
+;; (make-integer 2))
+;; ...)
+
+
+;; begin previous tests
+(test-case (equ? (add (make-integer 3) (make-integer 4))
+ (sub (make-integer 12) (make-integer 5))) #t)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3))) #t)
+(test-case (equ? (add (make-integer 3) (make-integer 3))
+ (sub (make-integer 12) (make-integer 5))) #f)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 2))) #f)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3)))) #t)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 4)))) #f)
+(test-case (make-integer 5) 5)
+(test-case (type-tag (make-integer 5)) 'integer)
+(test-case (type-tag (make-real 5)) 'real)
+(test-case (make-real 1.66667) 1.66667)
+(test-case (make-real (/ 5 3)) 1.66667)
+(test-case (type-tag (make-real (/ 5 3))) 'real)
+
+(test-case (div (make-integer 3) (make-integer 4)) 0)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6))))) #t)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 5))))) #f)
+(test-case (equ? (add (make-rational 7 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6)))) #t)
+(test-case (equ? (add (make-rational 3 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 1 6)))) #f)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))) #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 5)))) #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+(test-case (raise (make-integer 5)) '(rational 5 . 1))
+(test-case (raise (raise (make-integer 5))) 5.)
+(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0))
+
+(test-case (raise (make-rational 5 3)) 1.666667)
+(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0))
+;; end previous tests
+
blob - /dev/null
blob + 4de56baf7b84065ffc2b7eb2f502656f718f4d2f (mode 644)
--- /dev/null
+++ ex2-84b.scm~
+;; Exercise 2.83. Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex).
+
+;; we have to modify our packages so that we have 4 types: integer, rational, real, and complex
+
+(define (attach-tag type-tag contents)
+ (if (or (eq? type-tag 'integer)
+ (eq? type-tag 'real))
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((pair? datum) (car datum))
+ ((exact? datum) 'integer)
+ ((number? datum) 'real)
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((pair? datum) (cdr datum))
+ ((exact? datum) datum)
+ ((number? datum) (exact->inexact datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+;; (define coercion-table (make-table))
+;; (define get-coercion (coercion-table 'lookup-proc))
+;; (define put-coercion (coercion-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+(define (raise x) (apply-generic 'raise x))
+
+(define (install-integer-package)
+ (define (tag x) (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (quotient x y))))
+ ;; (if (integer? (/ x y))
+ ;; (tag (/ x y))
+ ;; (div (raise (tag x))
+ ;; (raise (tag y))))))
+ ;; ;; we avoided calling make-rational to avoid dependencies
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) zero?)
+ (put 'make 'integer
+ (lambda (n)
+ (if (exact? n)
+ (tag n)
+ (error "Not an exact integer" n))))
+ (put 'raise '(integer)
+ (lambda (x) (make-rational x 1)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (if (not (and (integer? n) (integer? d)))
+ (error "Both numerator and denominator must be integers"
+ (list n d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'raise '(rational)
+ (lambda (x) (make-real (/ (numer x) (denom x)))))
+
+ 'done)
+
+(define (install-real-package)
+ (define (tag x) (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real) zero?)
+ (put 'make 'real
+ (lambda (n)
+ (if (rational? n)
+ (tag (exact->inexact n))
+ (tag n))))
+ (put 'raise '(real)
+ (lambda (x) (make-complex-from-real-imag x 0)))
+
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (install-polynomial-package)
+ (define (tag x) (attach-tag 'polynomial x))
+ 'done)
+
+
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-real n)
+ ((get 'make 'real) n))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; (define (apply-generic op . args)
+;; (let ((type-tags (map type-tag args)))
+;; (let ((proc (get op type-tags)))
+;; (if proc
+;; (apply proc (map contents args))
+;; (if (= (length args) 2)
+;; (let ((type1 (car type-tags))
+;; (type2 (cadr type-tags))
+;; (a1 (car args))
+;; (a2 (cadr args)))
+;; (let ((t1->t2 (get-coercion type1 type2))
+;; (t2->t1 (get-coercion type2 type1)))
+;; (cond (t1->t2
+;; (apply-generic op (t1->t2 a1) a2))
+;; (t2->t1
+;; (apply-generic op a1 (t2->t1 a2)))
+;; (else
+;; (error "No method for these types"
+;; (list op type-tags))))))
+;; (error "No method for these types"
+;; (list op type-tags)))))))
+
+;; install number packages
+
+(install-integer-package)
+(install-rational-package)
+(install-real-package)
+(install-complex-package)
+(install-polynomial-package)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (equ? (add (make-integer 3) (make-integer 4))
+ (sub (make-integer 12) (make-integer 5))) #t)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3))) #t)
+(test-case (equ? (add (make-integer 3) (make-integer 3))
+ (sub (make-integer 12) (make-integer 5))) #f)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 2))) #f)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3)))) #t)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 4)))) #f)
+(test-case (make-integer 5) 5)
+(test-case (type-tag (make-integer 5)) 'integer)
+(test-case (type-tag (make-real 5)) 'real)
+(test-case (make-real 1.66667) 1.66667)
+(test-case (make-real (/ 5 3)) 1.66667)
+(test-case (type-tag (make-real (/ 5 3))) 'real)
+
+(test-case (div (make-integer 3) (make-integer 4)) 0)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6))))) #t)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 5))))) #f)
+(test-case (equ? (add (make-rational 7 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6)))) #t)
+(test-case (equ? (add (make-rational 3 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 1 6)))) #f)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))) #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 5)))) #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+(test-case (raise (make-integer 5)) '(rational 5 . 1))
+(test-case (raise (raise (make-integer 5))) 5.)
+(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0))
+
+(test-case (raise (make-rational 5 3)) 1.666667)
+(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0))
+
+;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower.
+
+;; (define (raise-to-second-type arg1 arg2)
+;; (if (eq? (type-tag arg1) (type-tag arg2))
+;; (cons arg1 arg2)
+;; (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+;; (if raise-proc
+;; (raise-to-second-type (raise-proc (contents arg1)) arg2)
+;; #f))))
+
+;; (test-case (raise-to-second-type (make-integer 5)
+;; (make-complex-from-real-imag 4 6))
+;; '((complex rectangular 5 . 0) . (complex rectangular 4 . 6)))
+;; (test-case (raise-to-second-type (make-complex-from-mag-ang 4 3)
+;; (make-complex-from-real-imag 2 3))
+;; '((complex polar 4 . 3) . (complex rectangular 2 . 3)))
+;; (test-case (raise-to-second-type (make-rational 5 3)
+;; (make-integer 2))
+;; #f)
+;; (test-case (raise-to-second-type (make-complex-from-mag-ang 5 3)
+;; (make-rational 2 6))
+;; #f)
+;; (test-case (raise-to-second-type (make-rational 4 2)
+;; (make-real 4.5))
+;; '(2. . 4.5))
+
+;; not going to call apply-generic recursively so we can get more informative error messages
+;; we could have apply-generic return #f if a procedure isn't found. This could help us avoid a helper function like raise-to-second-type, and we could then just raise recursively, but then we'd lose the error messages.
+
+(define (apply-generic op . args)
+ ;; return arg1 raised to same type as arg2, #f if not possible
+ (define (raise-to-second-type arg1 arg2)
+ (if (eq? (type-tag arg1) (type-tag arg2))
+ (cons arg1 arg2)
+ (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+ (if raise-proc
+ (raise-to-second-type (raise-proc (contents arg1)) arg2)
+ #f))))
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((a1 (car args))
+ (a2 (cadr args)))
+ (if (eq? (type-tag a1) (type-tag a2))
+ (error "No method for these common types" (list op type-tags))
+ (let ((raised-pair (or (raise-to-second-type a1 a2)
+ (raise-to-second-type a2 a1))))
+ (if raised-pair
+ (let ((raised1 (car raised-pair))
+ (raised2 (cdr raised-pair)))
+ (apply-generic op raised1 raised2))
+ (error "No common supertype"
+ (list op type-tags)))))) ;; error messages may not be accurate
+ (error "No method for these (≠2) types"
+ (list op type-tags))))) ;; error messages may not be accurate
+
+(test-case (add (make-integer 5) (make-rational 3 1))
+ (make-rational 8 1))
+(test-case (div (make-integer 2) (make-real 5))
+ 0.4)
+(test-case (mul (make-complex-from-real-imag 3 4)
+ (make-integer 2))
+ ...)
+
blob - /dev/null
blob + c379d110ae817db8bb0f70581b026e16b489ffcd (mode 644)
--- /dev/null
+++ ex2-84c.scm
+(define (attach-tag type-tag contents)
+ (if (or (eq? type-tag 'integer)
+ (eq? type-tag 'real))
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((pair? datum) (car datum))
+ ((exact? datum) 'integer)
+ ((number? datum) 'real)
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((pair? datum) (cdr datum))
+ ((exact? datum) datum)
+ ((number? datum) (exact->inexact datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+(define (raise x) (apply-generic 'raise x))
+
+(define (install-integer-package)
+ (define (tag x) (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (quotient x y))))
+ ;; (if (integer? (/ x y))
+ ;; (tag (/ x y))
+ ;; (div (raise (tag x))
+ ;; (raise (tag y))))))
+ ;; ;; we avoided calling make-rational to avoid dependencies
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) zero?)
+ (put 'make 'integer
+ (lambda (n)
+ (if (exact? n)
+ (tag n)
+ (error "Not an exact integer" n))))
+ (put 'raise '(integer)
+ (lambda (x) (make-rational x 1)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (if (not (and (integer? n) (integer? d)))
+ (error "Both numerator and denominator must be integers"
+ (list n d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'raise '(rational)
+ (lambda (x) (make-real (/ (numer x) (denom x)))))
+
+ 'done)
+
+(define (install-real-package)
+ (define (tag x) (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real) zero?)
+ (put 'make 'real
+ (lambda (n)
+ (if (rational? n)
+ (tag (exact->inexact n))
+ (tag n))))
+ (put 'raise '(real)
+ (lambda (x) (make-complex-from-real-imag x 0)))
+
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (install-polynomial-package)
+ (define (tag x) (attach-tag 'polynomial x))
+ 'done)
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-real n)
+ ((get 'make 'real) n))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; install number packages
+
+(install-integer-package)
+(install-rational-package)
+(install-real-package)
+(install-complex-package)
+(install-polynomial-package)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower.
+
+;; not going to call apply-generic recursively so we can get more informative error messages
+;; we could have apply-generic return #f if a procedure isn't found. This could help us avoid a helper function like raise-to-second-type, and we could then just raise recursively, but then we'd lose the error messages.
+
+(define (apply-generic op . args)
+ ;; return arg1 raised to same type as arg2, #f if not possible
+ (define (raise-to-second-type arg1 arg2)
+ (if (eq? (type-tag arg1) (type-tag arg2))
+ arg1
+ (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+ (if raise-proc
+ (raise-to-second-type (raise-proc (contents arg1)) arg2)
+ #f))))
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((a1 (car args))
+ (a2 (cadr args)))
+ (if (eq? (type-tag a1) (type-tag a2))
+ (list "No method for these common types" (list op type-tags))
+ (let ((raised1 (raise-to-second-type a1 a2))
+ (raised2 (raise-to-second-type a2 a1)))
+ (cond (raised1
+ (let ((proc (get op (list (type-tag raised1) (type-tag a2)))))
+ (if proc
+ (apply-generic proc raised1 a2)
+ (list "No procedure, even after raising first argument"
+ (list op type-tags)))))
+ (raised2
+ (let ((proc (get op (list a1 (type-tag raised2)))))
+ (if proc
+ (apply-generic proc a1 raised2)
+ (list "No procedure, even after raising second argument"
+ (list op type-tags)))))
+ (else (list "No common supertype" (list op type-tags)))))))))))
+
+
+
+(test-case (add (make-integer 4) '(nonsense-type . 3))
+ '("No common supertype" (add (integer nonsense-type))))
+(test-case (apply-generic 'dummy (make-integer 3) (make-real 4.))
+ '("No procedure, even after raising first argument" (dummy (integer real))))
+(test-case (apply-generic 'dummy (make-real 4.) (make-integer 3))
+ '("No procedure, even after raising second argument" (dummy (real integer))))
+
+
+(test-case (add (make-integer 5) (make-rational 3 1))
+ (make-rational 8 1))
+(test-case (div (make-integer 2) (make-real 5))
+ 0.4)
+(test-case (mul (make-complex-from-real-imag 3 4)
+ (make-integer 2))
+ ...)
+
+
+;; begin previous tests
+(test-case (equ? (add (make-integer 3) (make-integer 4))
+ (sub (make-integer 12) (make-integer 5))) #t)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3))) #t)
+(test-case (equ? (add (make-integer 3) (make-integer 3))
+ (sub (make-integer 12) (make-integer 5))) #f)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 2))) #f)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3)))) #t)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 4)))) #f)
+(test-case (make-integer 5) 5)
+(test-case (type-tag (make-integer 5)) 'integer)
+(test-case (type-tag (make-real 5)) 'real)
+(test-case (make-real 1.66667) 1.66667)
+(test-case (make-real (/ 5 3)) 1.66667)
+(test-case (type-tag (make-real (/ 5 3))) 'real)
+
+(test-case (div (make-integer 3) (make-integer 4)) 0)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6))))) #t)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 5))))) #f)
+(test-case (equ? (add (make-rational 7 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6)))) #t)
+(test-case (equ? (add (make-rational 3 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 1 6)))) #f)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))) #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 5)))) #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+(test-case (raise (make-integer 5)) '(rational 5 . 1))
+(test-case (raise (raise (make-integer 5))) 5.)
+(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0))
+
+(test-case (raise (make-rational 5 3)) 1.666667)
+(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0))
+;; end previous tests
+
blob - /dev/null
blob + 2285530eed2a714a0c0dd7c41898d399fe6a9e92 (mode 644)
--- /dev/null
+++ ex2-84c.scm~
+(define (attach-tag type-tag contents)
+ (if (or (eq? type-tag 'integer)
+ (eq? type-tag 'real))
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((pair? datum) (car datum))
+ ((exact? datum) 'integer)
+ ((number? datum) 'real)
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((pair? datum) (cdr datum))
+ ((exact? datum) datum)
+ ((number? datum) (exact->inexact datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+(define (raise x) (apply-generic 'raise x))
+
+(define (install-integer-package)
+ (define (tag x) (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (quotient x y))))
+ ;; (if (integer? (/ x y))
+ ;; (tag (/ x y))
+ ;; (div (raise (tag x))
+ ;; (raise (tag y))))))
+ ;; ;; we avoided calling make-rational to avoid dependencies
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) zero?)
+ (put 'make 'integer
+ (lambda (n)
+ (if (exact? n)
+ (tag n)
+ (error "Not an exact integer" n))))
+ (put 'raise '(integer)
+ (lambda (x) (make-rational x 1)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (if (not (and (integer? n) (integer? d)))
+ (error "Both numerator and denominator must be integers"
+ (list n d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'raise '(rational)
+ (lambda (x) (make-real (/ (numer x) (denom x)))))
+
+ 'done)
+
+(define (install-real-package)
+ (define (tag x) (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real) zero?)
+ (put 'make 'real
+ (lambda (n)
+ (if (rational? n)
+ (tag (exact->inexact n))
+ (tag n))))
+ (put 'raise '(real)
+ (lambda (x) (make-complex-from-real-imag x 0)))
+
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (install-polynomial-package)
+ (define (tag x) (attach-tag 'polynomial x))
+ 'done)
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-real n)
+ ((get 'make 'real) n))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; install number packages
+
+(install-integer-package)
+(install-rational-package)
+(install-real-package)
+(install-complex-package)
+(install-polynomial-package)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower.
+
+;; (define (raise-to-second-type arg1 arg2)
+;; (if (eq? (type-tag arg1) (type-tag arg2))
+;; arg1
+;; (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+;; (if raise-proc
+;; (raise-to-second-type (raise-proc (contents arg1)) arg2)
+;; #f))))
+
+;; (test-case (raise-to-second-type (make-integer 5)
+;; (make-complex-from-real-imag 4 6))
+;; '(complex rectangular 5. . 0))
+;; (test-case (raise-to-second-type (make-complex-from-mag-ang 4 3)
+;; (make-complex-from-real-imag 2 3))
+;; '(complex polar 4 . 3)) ;; should there be a decimal point after 4 and 3?
+;; (test-case (raise-to-second-type (make-rational 5 3)
+;; (make-integer 2))
+;; #f)
+;; (test-case (raise-to-second-type (make-complex-from-mag-ang 5 3)
+;; (make-rational 2 6))
+;; #f)
+;; (test-case (raise-to-second-type (make-rational 4 2)
+;; (make-real 4.5))
+;; 2.)
+
+;; not going to call apply-generic recursively so we can get more informative error messages
+;; we could have apply-generic return #f if a procedure isn't found. This could help us avoid a helper function like raise-to-second-type, and we could then just raise recursively, but then we'd lose the error messages.
+
+(define (apply-generic op . args)
+ ;; return arg1 raised to same type as arg2, #f if not possible
+ (define (raise-to-second-type arg1 arg2)
+ (if (eq? (type-tag arg1) (type-tag arg2))
+ arg1
+ (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+ (if raise-proc
+ (raise-to-second-type (raise-proc (contents arg1)) arg2)
+ #f))))
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((a1 (car args))
+ (a2 (cadr args)))
+ (if (eq? (type-tag a1) (type-tag a2))
+ (list "No method for these common types" (list op type-tags))
+ (let ((raised1 (raise-to-second-type a1 a2))
+ (raised2 (raise-to-second-type a2 a1)))
+ (cond (raised1
+ (let ((proc (get op (list (type-tag raised1) (type-tag a2)))))
+ (if proc
+ (apply-generic proc raised1 a2)
+ (list "No procedure, even after raising first argument"
+ (list op type-tags)))))
+ (raised2
+ (let ((proc (get op (list a1 (type-tag raised2)))))
+ (if proc
+ (apply-generic proc a1 raised2)
+ (list "No procedure, even after raising second argument"
+ (list op type-tags)))))
+ (else (list "No common supertype" (list op type-tags)))))))))))
+
+
+
+;; (test-case (add (make-integer 4) '(nonsense-type . 3))
+;; '("No common supertype" (add (integer nonsense-type))))
+;; (test-case (apply-generic 'dummy (make-integer 3) (make-real 4.))
+;; '("No procedure, even after raising first argument" (dummy (integer real))))
+;; (test-case (apply-generic 'dummy (make-real 4.) (make-integer 3))
+;; '("No procedure, even after raising second argument" (dummy (real integer))))
+
+
+;; (test-case (add (make-integer 5) (make-rational 3 1))
+;; (make-rational 8 1))
+;; (test-case (div (make-integer 2) (make-real 5))
+;; 0.4)
+;; (test-case (mul (make-complex-from-real-imag 3 4)
+;; (make-integer 2))
+;; ...)
+
+
+;; begin previous tests
+(test-case (equ? (add (make-integer 3) (make-integer 4))
+ (sub (make-integer 12) (make-integer 5))) #t)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3))) #t)
+(test-case (equ? (add (make-integer 3) (make-integer 3))
+ (sub (make-integer 12) (make-integer 5))) #f)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 2))) #f)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3)))) #t)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 4)))) #f)
+(test-case (make-integer 5) 5)
+(test-case (type-tag (make-integer 5)) 'integer)
+(test-case (type-tag (make-real 5)) 'real)
+(test-case (make-real 1.66667) 1.66667)
+(test-case (make-real (/ 5 3)) 1.66667)
+(test-case (type-tag (make-real (/ 5 3))) 'real)
+
+(test-case (div (make-integer 3) (make-integer 4)) 0)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6))))) #t)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 5))))) #f)
+(test-case (equ? (add (make-rational 7 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6)))) #t)
+(test-case (equ? (add (make-rational 3 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 1 6)))) #f)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))) #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 5)))) #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+(test-case (raise (make-integer 5)) '(rational 5 . 1))
+(test-case (raise (raise (make-integer 5))) 5.)
+(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0))
+
+(test-case (raise (make-rational 5 3)) 1.666667)
+(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0))
+;; end previous tests
+
blob - /dev/null
blob + 3b4e5d043946a4d08e1569d397f1f0314d32cf4b (mode 644)
--- /dev/null
+++ ex2-84d.scm
+(define (attach-tag type-tag contents)
+ (if (or (eq? type-tag 'integer)
+ (eq? type-tag 'real))
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((pair? datum) (car datum))
+ ((exact? datum) 'integer)
+ ((number? datum) 'real)
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((pair? datum) (cdr datum))
+ ((exact? datum) datum)
+ ((number? datum) (exact->inexact datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+(define (raise x) (apply-generic 'raise x))
+
+(define (install-integer-package)
+ (define (tag x) (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (quotient x y))))
+ ;; (if (integer? (/ x y))
+ ;; (tag (/ x y))
+ ;; (div (raise (tag x))
+ ;; (raise (tag y))))))
+ ;; ;; we avoided calling make-rational to avoid dependencies
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) zero?)
+ (put 'make 'integer
+ (lambda (n)
+ (if (exact? n)
+ (tag n)
+ (error "Not an exact integer" n))))
+ (put 'raise '(integer)
+ (lambda (x) (make-rational x 1)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (if (not (and (integer? n) (integer? d)))
+ (error "Both numerator and denominator must be integers"
+ (list n d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'raise '(rational)
+ (lambda (x) (make-real (/ (numer x) (denom x)))))
+
+ 'done)
+
+(define (install-real-package)
+ (define (tag x) (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real) zero?)
+ (put 'make 'real
+ (lambda (n)
+ (if (rational? n)
+ (tag (exact->inexact n))
+ (tag n))))
+ (put 'raise '(real)
+ (lambda (x) (make-complex-from-real-imag x 0)))
+
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-real n)
+ ((get 'make 'real) n))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; install number packages
+
+(install-integer-package)
+(install-rational-package)
+(install-real-package)
+(install-complex-package)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower.
+
+(define (apply-generic op . args)
+ ;; return arg1 raised to same type as arg2, #f if not possible
+ (define (raise-to-second-type arg1 arg2)
+ (if (eq? (type-tag arg1) (type-tag arg2))
+ arg1
+ (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+ (if raise-proc
+ (raise-to-second-type (raise-proc (contents arg1)) arg2)
+ #f))))
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((a1 (car args))
+ (a2 (cadr args)))
+ (if (eq? (type-tag a1) (type-tag a2))
+ (list "No method for these (raised) types" (list op type-tags))
+ (let ((raised1 (raise-to-second-type a1 a2))
+ (raised2 (raise-to-second-type a2 a1)))
+ (cond (raised1 (apply-generic op raised1 a2))
+ (raised2 (apply-generic op a1 raised2))
+ (else (list "No common supertype" (list op type-tags)))))))))))
+
+(test-case (add (make-integer 4) '(nonsense-type . 3))
+ '("No common supertype" (add (integer nonsense-type))))
+(test-case (apply-generic 'dummy (make-integer 3) (make-real 4.))
+ '("No method for these (raised) types" (dummy (real real))))
+(test-case (apply-generic 'dummy (make-real 4.) (make-integer 3))
+ '("No method for these (raised) types" (dummy (real real))))
+
+
+(test-case (add (make-integer 5) (make-rational 3 1))
+ (make-rational 8 1))
+(test-case (div (make-integer 2) (make-real 5))
+ 0.4)
+(test-case (div (make-real 5) (make-integer 2))
+ 2.5)
+
+(test-case (mul (div (make-complex-from-mag-ang 3 2)
+ (make-integer 3))
+ (add (make-real 2.4)
+ (make-rational 4 3)))
+ '(complex polar 3.733333333334 . 2.))
+
+;; begin previous tests
+(test-case (equ? (add (make-integer 3) (make-integer 4))
+ (sub (make-integer 12) (make-integer 5))) #t)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3))) #t)
+(test-case (equ? (add (make-integer 3) (make-integer 3))
+ (sub (make-integer 12) (make-integer 5))) #f)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 2))) #f)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3)))) #t)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 4)))) #f)
+(test-case (make-integer 5) 5)
+(test-case (type-tag (make-integer 5)) 'integer)
+(test-case (type-tag (make-real 5)) 'real)
+(test-case (make-real 1.66667) 1.66667)
+(test-case (make-real (/ 5 3)) 1.66667)
+(test-case (type-tag (make-real (/ 5 3))) 'real)
+
+(test-case (div (make-integer 3) (make-integer 4)) 0)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6))))) #t)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 5))))) #f)
+(test-case (equ? (add (make-rational 7 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6)))) #t)
+(test-case (equ? (add (make-rational 3 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 1 6)))) #f)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))) #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 5)))) #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+(test-case (raise (make-integer 5)) '(rational 5 . 1))
+(test-case (raise (raise (make-integer 5))) 5.)
+(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0))
+
+(test-case (raise (make-rational 5 3)) 1.666667)
+(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0))
+;; end previous tests
+
blob - /dev/null
blob + 676c8ebd49ab87c2cb21b0f8b6fe424a1c3468f6 (mode 644)
--- /dev/null
+++ ex2-84d.scm~
+(define (attach-tag type-tag contents)
+ (if (or (eq? type-tag 'integer)
+ (eq? type-tag 'real))
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((pair? datum) (car datum))
+ ((exact? datum) 'integer)
+ ((number? datum) 'real)
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((pair? datum) (cdr datum))
+ ((exact? datum) datum)
+ ((number? datum) (exact->inexact datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+(define (raise x) (apply-generic 'raise x))
+
+(define (install-integer-package)
+ (define (tag x) (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (quotient x y))))
+ ;; (if (integer? (/ x y))
+ ;; (tag (/ x y))
+ ;; (div (raise (tag x))
+ ;; (raise (tag y))))))
+ ;; ;; we avoided calling make-rational to avoid dependencies
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) zero?)
+ (put 'make 'integer
+ (lambda (n)
+ (if (exact? n)
+ (tag n)
+ (error "Not an exact integer" n))))
+ (put 'raise '(integer)
+ (lambda (x) (make-rational x 1)))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (if (not (and (integer? n) (integer? d)))
+ (error "Both numerator and denominator must be integers"
+ (list n d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'raise '(rational)
+ (lambda (x) (make-real (/ (numer x) (denom x)))))
+
+ 'done)
+
+(define (install-real-package)
+ (define (tag x) (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real) zero?)
+ (put 'make 'real
+ (lambda (n)
+ (if (rational? n)
+ (tag (exact->inexact n))
+ (tag n))))
+ (put 'raise '(real)
+ (lambda (x) (make-complex-from-real-imag x 0)))
+
+ 'done)
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ 'done)
+
+(define (install-polynomial-package)
+ (define (tag x) (attach-tag 'polynomial x))
+ 'done)
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-real n)
+ ((get 'make 'real) n))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; install number packages
+
+(install-integer-package)
+(install-rational-package)
+(install-real-package)
+(install-complex-package)
+(install-polynomial-package)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.84. Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower.
+
+(define (apply-generic op . args)
+ ;; return arg1 raised to same type as arg2, #f if not possible
+ (define (raise-to-second-type arg1 arg2)
+ (if (eq? (type-tag arg1) (type-tag arg2))
+ arg1
+ (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+ (if raise-proc
+ (raise-to-second-type (raise-proc (contents arg1)) arg2)
+ #f))))
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((a1 (car args))
+ (a2 (cadr args)))
+ (if (eq? (type-tag a1) (type-tag a2))
+ (list "No method for these (raised) types" (list op type-tags))
+ (let ((raised1 (raise-to-second-type a1 a2))
+ (raised2 (raise-to-second-type a2 a1)))
+ (cond (raised1 (apply-generic op raised1 a2))
+ (raised2 (apply-generic op a1 raised2))
+ (else (list "No common supertype" (list op type-tags)))))))))))
+
+(test-case (add (make-integer 4) '(nonsense-type . 3))
+ '("No common supertype" (add (integer nonsense-type))))
+(test-case (apply-generic 'dummy (make-integer 3) (make-real 4.))
+ '("No method for these (raised) types" (dummy (real real))))
+(test-case (apply-generic 'dummy (make-real 4.) (make-integer 3))
+ '("No method for these (raised) types" (dummy (real real))))
+
+
+(test-case (add (make-integer 5) (make-rational 3 1))
+ (make-rational 8 1))
+(test-case (div (make-integer 2) (make-real 5))
+ 0.4)
+(test-case (mul (div (make-complex-from-mag-ang 3 2)
+ (make-integer 3))
+ (add (make-real 2.4)
+ (make-rational 4 3)))
+ '(complex polar 3.733333333334 . 2.))
+
+;; begin previous tests
+(test-case (equ? (add (make-integer 3) (make-integer 4))
+ (sub (make-integer 12) (make-integer 5))) #t)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3))) #t)
+(test-case (equ? (add (make-integer 3) (make-integer 3))
+ (sub (make-integer 12) (make-integer 5))) #f)
+(test-case (equ? (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 2))) #f)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 3)))) #t)
+(test-case (=zero? (sub (div (make-integer 24) (make-integer 4))
+ (mul (make-integer 2) (make-integer 4)))) #f)
+(test-case (make-integer 5) 5)
+(test-case (type-tag (make-integer 5)) 'integer)
+(test-case (type-tag (make-real 5)) 'real)
+(test-case (make-real 1.66667) 1.66667)
+(test-case (make-real (/ 5 3)) 1.66667)
+(test-case (type-tag (make-real (/ 5 3))) 'real)
+
+(test-case (div (make-integer 3) (make-integer 4)) 0)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6))))) #t)
+(test-case (=zero? (sub (make-rational 4 1)
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 5))))) #f)
+(test-case (equ? (add (make-rational 7 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 2 6)))) #t)
+(test-case (equ? (add (make-rational 3 2)
+ (make-rational 2 4))
+ (div (add (make-rational 1 2)
+ (make-rational 3 2))
+ (mul (make-rational 3 2)
+ (make-rational 1 6)))) #f)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 4)))) #t)
+(test-case (equ? (div (make-rational 4 2)
+ (make-rational 1 3))
+ (sub (make-rational 9 1)
+ (mul (make-rational 4 1)
+ (make-rational 3 5)))) #f)
+(test-case (equ? (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #t)
+(test-case (equ? (add (make-complex-from-real-imag 3 4.5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1))
+ #f)
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 4)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #t)
+
+(test-case (=zero? (sub (add (make-complex-from-real-imag 3 5)
+ (make-complex-from-real-imag -5 -3))
+ '(complex rectangular -2 . 1)))
+ #f)
+
+
+(test-case (raise (make-integer 5)) '(rational 5 . 1))
+(test-case (raise (raise (make-integer 5))) 5.)
+(test-case (raise (raise (raise (make-integer 5)))) '(complex rectangular 5. . 0))
+
+(test-case (raise (make-rational 5 3)) 1.666667)
+(test-case (raise (raise (make-rational 5 3))) '(complex rectangular 1.666667 . 0))
+;; end previous tests
+
blob - /dev/null
blob + 9eb021685643b263ceefdc7a1e976f63d0f2e707 (mode 644)
--- /dev/null
+++ ex2-85-sol.scm
+(define (install-rational-package)
+ (define (rational->integer r)
+ (make-integer (quotient (numer r) (denom r))))
+ (put-coercion 'rational 'integer rational->integer)
+ 'done)
+(define (install-real-package)
+ (define (real->rational r)
+ (make-rational (inexact->exact (numerator r))
+ (inexact->exact (denominator r))))
+ (put-coercion 'real 'rational real->rational)
+ 'done)
+(define (install-complex-package)
+ (define (complex->real z)
+ (make-real (complex-real-part z)))
+ (put-coercion 'complex 'real complex->real)
+ 'done)
+
+(define (apply-raise x types)
+ (cond ((null? types)
+ (error "Type not found in the tower-of-types"
+ (list (type-tag x) tower-of-types)))
+ ((eq? (type-tag x) (car types))
+ (if (null? (cdr types))
+ x
+ (let ((raiser (get-coercion (type-tag x) (cadr types))))
+ (if raiser
+ (raiser (contents x))
+ (error "No coercion procedure found for types"
+ (list (type-tag x) (cadr types)))))))
+ (else (apply-raise x (cdr types)))))
+(define (raise x)
+ (apply-raise x tower-of-types))
+(define (project x)
+ (apply-raise x (reverse tower-of-types)))
+(define (project x)
+ (define (apply-project types)
+ (cond ((eq? (type-tag x) (car types)) x)
+ ((or (null? types) (null? (cdr types)))
+ (error "type not found in the tower-of-types"
+ (list (type-tag x) tower-of-types)))
+ ((eq? (type-tag x) (cadr types))
+ (let ((projector (get-coercion (type-tag x) (car types))))
+ (if projector
+ (projector (contents x))
+ (error "No coercion procedure found for types"
+ (list (car types) (type-tag x))))))
+ (else (apply-project (cdr types)))))
+ (apply-project tower-of-types))
+
+
+(define (install-rational-package)
+ (define (rational->integer r)
+ (make-integer (round (/ (numer r) (denom r)))))
+ (put-coercion 'rational 'integer rational->integer)
+ 'done)
+
+(define (install-real-package)
+ (define (real->rational r)
+ (make-rational (inexact->exact (numerator r))
+ (inexact->exact (denominator r))))
+ (put-coercion 'real 'rational real->rational)
+ 'done)
+
+(define (install-complex-package)
+ (define (complex->real z)
+ (make-real (complex-real-part z)))
+ (put-coercion 'complex 'real complex->real)
+ 'done)
+
+(define (apply-raise x types)
+ (cond ((null? types)
+ (error "Type not found in the tower-of-types"
+ (list (type-tag x) tower-of-types)))
+ ((eq? (type-tag x) (car types))
+ (if (null? (cdr types))
+ x
+ (let ((raiser (get-coercion (type-tag x) (cadr types))))
+ (if raiser
+ (raiser (contents x))
+ (error "No coercion procedures found for types"
+ (list (type-tag x) (cadr types)))))))
+ (else (apply-raise x (cdr types)))))
+
+(define (raise x)
+ (apply-raise x tower-of-types))
+(define (project x)
+ (apply-raise x (reverse tower-of-types)))
+
+(define (project x)
+ (define (apply-project types)
+ (cond ((eq? (type-tag x) (car types)) x)
+ ((or (null? types) (null? (cdr types)))
+ (error "type not found in the tower-of-types"
+ (list (type-tag x) tower-of-types)))
+
+(define (make-rat n d)
+ (if (and (integer? n) (integer? d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))
+ (error "non-integer numerator of denominator"
+ (list n d))))
+
+(define (make-from-real-imag x y)
+ (if (and (in-tower? x) (in-tower? y))
+ (cons x y)
+ (error "non-real real or imaginary value" (list x y))))
+
+(define (make-from-mag-ang r a)
+ (if (and (real? r) (real? a))
+ (cons (* r (cos a)) (* r (sin a)))
+ (error "non-real magnitude or angle" (list r a))))
+
+(define (make-from-mag-ang r a)
+ (if (and (in-tower? r) (in-tower? a))
+ (cons r a)
+ (error "non-real magnitude or angle" (list r a))))
+(define (make-from-real-imag x y)
+ (if (and (in-tower? x) (in-tower? y))
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x))
+ (error "non-real real or imaginary value" (list x y))))
+
+(define (integer->rational i) (make-rational i 1))
+(define (rational->real r) (make-real (/ (numer r) (denom r))))
+(define (real->complex r) (make-complex-from-real-imag r 0))
+(define (raise x) (apply-geeric 'raise x))
+
+(define (tower-of-types '(integer rational real complex))
+(define (raise x)
+ (define (apply-raise types)
+ (cond ((null? types)
+ (error "Type not found in the tower-of-types"
+ (list x tower-of-types)))
+ ((eq? (type-tag x) (car types))
+ (if (null? (cdr types))
+ x
+ (let ((raiser (get-coercion (type-tag x) (cadr types))))
+ (if raiser
+ (raiser (contents x))
+ (error "No coercion procedure found for types"
+ (list (type-tag x) (cadr types))))))
+ (else (apply-raise (cdr types))))))
+ (apply-raise tower-of-types))
+(put-coercion 'integer 'rational integer->rational)
+(put-coercion 'rational 'real rational->real)
+(put-coercion 'real 'complex real->complex)
+
+(define (find-highest-type l)
+ (define (filter-type t f)
+ (cond ((null? f) '())
+ ((eq? (car f) t) (filter-type t (cdr f)))
+ (else (cons (car f) (filter-type t (cdr f))))))
+ (define (find-highest highest remaining-tower remaining-list)
+ (cond ((null? remaining-list) highest)
+ ((null? remaining-tower)
+ (error "Cannot find highest type from non-tower types -- FIND-HIGHEST-TYPE"
+ remaining-list))
+ (else (find-highest (car remaining-tower)
+ (cdr remaining-tower)
+ (filter-type (car remaining-tower) remaining-list)))))
+ (find-highest #f tower-of-types l))
+
+(find-highest-type '(integer real ratinoal real))
+(find-highest-type '(rational rational rational))
+(find-highest-type '(complex real rational integer))
+(find-highest-type '())
+(find-highest-type '(integer wibble real wobble complex))
+(define (raise-to type value)
+ (cond ((eq? type (type-tag value)) value)
+ ((memq type tower-of-types) (raise-to type (raise value)))
+ (else (error "Cannot raise to non-tower type -- RAISE-TO"
+ (list type tower-of-types)))))
+(raise-to 'real (make-integer 4)
+(raise-to 'complex (make-rational 3 4))
+(raise-to 'real (make-real 3.14159))
+(raise-to 'wibble (make-integer 42))
+(define (raise-all-to type values)
+ (if (null? values)
+ '()
+ (cons (raise-to type (car values)) (raise-all-to type (cdr values)))))
+(raise-all-to 'real (list (make-integer 42) (make-real 3.14159) (make-rational 3 4)))
+(raise-all-to 'complex '())
+(raise-all-to 'wibble (list (make-integer 123)))
+
+(define (apply-generic op . args)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (> (length args) 1)
+ (let* ((highest-type (find-highest-type type-tags))
+ (mapped-args (raise-all-to highest-type args))
+ (mapped-types (map type-tag mapped-args))
+ (mapped-proc (get op mapped-types)))
+ (if mapped-proc
+ (apply mapped-proc (map contents mapped-args))
+ (error "No method for these types -- APPLY-GENERIC"
+ (list op type-tags))))))))
+
+(define (install-integer-package)
+ (put 'addd '(integer integer integer)
+ (lambda (x y z) (tag (+ x y z)))))
+
+(put 'addd '(rational rational rational)
+ (lambda (x y z) (tag (addd x y z))))
+(put 'addd '(real real real)
+ (lambda (x y z) (tag (+ x y z))))
+
+(define (rational->integer r) (make-integer (round (/ (numer r) (denom r)))))
+(put-coercion 'rational 'integer rational->integer)
+(define (real->rational r) (make-rational (inexact->exact (numerator r))
+ (inexact->exact (denominator r))))
+(put-coercion 'real 'rational real->rational)
+
+(define (complex->real z) (make-real (complex-real-part z)))
+(put-coercion 'complex 'real complex->real)
+
+(define (apply-raise x types)
+ (cond ((null? types)
+ (error "Type not found in the tower-of-types"
+ (list (type-tag x) tower-of-types)))
+ ((eq? (type-tag x) (car types))
+ (if (null? (cdr types))
+ x
+ (let ((raiser (get-coercion (type-tag x) (cadr types))))
+ (if raiser
+ (raiser (contents x))
+ (error "No coercion procedure found for types"
+ (list (type-tag x) (cadr types)))))))
+ (else (apply-raise x (cdr types)))))
+
+(define (raise x)
+ (apply-raise x tower-of-types))
+(define (project x)
+ (apply-raise x (reverse tower-of-types)))
+
+(define (project x)
+ (define (apply-project types)
+ (cond ((eq? (type-tag x) (car types)) x)
+ ((or (null? types) (null? (cdr types)))
+ (error "type not found in the tower-of-types"
+ (list (type-tag x) tower-of-types)))
+ ((eq? (type-tag x) (cadr types))
+ (let ((projector (get-coercion (type-tag x) (car types))))
+ (if projector
+ (projector (contents x))
+ (error "No coercion procedure found for types"
+ (list (car types) (type-tag x))))))
+ (else (apply-project (cdr types)))))
+ (apply-project tower-of-types))
+(project (make-real 3.5))
+(project (Make-rational 7 3))
+(raise (project (make-real 3.5)))
+(raise (project (make-rational 7 3)))
+(define (drop x)
+ (let* ((dropped (project x))
+ (raised (raise dropped)))
+ (if (and (not (eq? (type-tag x) (type-tag dropped)))
+ (equ? x raised))
+ (drop dropped)
+ x)))
+
+(define (apply-generic op . args)
+ (define (find-and-apply-op)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (> (length args) 1)
+ (let* ((highest-type (find-highest-type type-tags))
+ (mapped-args (raise-all-to highest-type args))
+ (mapped-types (map type-tag mapped-args))
+ (mapped-proc (get op mapped-types)))
+ (if mapped-proc
+ (apply mapped-proc (map contents mapped-args))
+ (error
+ "No method for these types -- APPLY-GENERIC"
+ (list op type-tags))))))))
+ (let ((result (find-and-apply-op)))
+ (if (and (pair? result)
+ (memq (type-tag result) tower-of-types))
+ (drop result)
+ result)))
+
+(define (apply-raise x types)
+ (cond ((null? types)
+ (error "Type not found in the tower-of-types"
+ (list (type-tag x) tower-of-types)))
+ ((eq? (type-tag x) (car types))
+ (if (null? (cdr types))
+ x
+ (let ((raiser (get-coercion (type-tag x) (cadr types))))
+ (if raiser
+ (raiser (contents x))
+ (error "No coercion procedure found for types"
+ (list (type-tag x) (cadr types)))))))
+ (else (apply-raise x (cdr types)))))
+(define (raise x)
+ (apply-raise x tower-of-types))
+(define (project x)
+ (apply-raise x (reverse tower-of-types)))
+(define (project x)
+ (define (apply-project types)
+ (cond ((eq? (type-tag x) (car types)) x)
+ ((or (null? types) (null? (cdr types)))
+ (error "type not found in the tower-of-types"
+ (list (type-tag x) tower-of-types)))
+ ((eq? (type-tag x) (cadr types))
+ (let ((projector (get-coercion (type-tag x) (car types))))
+ (if projector
+ (projector (contents x))
+ (error "No coercion procedure found for types"
+ (list (car types) (type-tag x))))))
+ (else (apply-project (cdr types)))))
+ (apply-project tower-of-types))
+
+(define (drop x)
+ (let* ((dropped (project x))
+ (raised (raise dropped)))
+ (if (and (not (eq? (type-tag x) (type-tag dropped)))
+ (equ? x raised))
+ (drop dropped)
+ x)))
+
+(define (apply-generic op . args)
+ (define (find-and-apply-op)
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (> (length args) 1)
+ (let* ((highest-type (find-highest-type type-tags))
+ (mapped-args (raise-all-to highest-type args))
+ (mapped-types (map type-tag mapped-args))
+ (mapped-proc (get op mapped-types)))
+ (if mapped-proc
+ (apply-mapped-proc (map contents mapped-args))
+ (error "No method for these types -- APPLY-GENERIC"
+ (list op type-tags))))))))
+ (let ((result (find-and-apply-op)))
+ (if (and (pair? result)
+ (memq (type-tag result) tower-of-types))
+ (drop result)
+ result)))
+
+(define (integer->rational n)
+ (make-rational n 1))
+(put 'raise '(integer)
+ (lambda (i) (integer->rational i)))
+(define (rational->real r)
+ (make-real
+ (exact->inexact
+ (/ (numer r) (denom r)))))
+(put 'raise '(rational)
+ (lambda (r) (rational->real r)))
+(define (real->complex r)
+ (make-complex-from-real-imag r 0))
+(put 'raise '(real)
+ (lambda (r) (real->complex r)))
+(define (raise x)
+ (apply-generic 'raise x))
+
+(define (apply-generic-r op . args)
+ (define (no-method type-tags)
+ (error "No method for these types"
+ (list op type-tags)))
+ (define (raise-into s t)
+ (let ((s-type (type-tag s))
+ (t-type (type-tag t)))
+ (cond
+ ((equal? s-type t-type) s)
+ ((get 'raise (list s-type))
+ (raise-into ((get 'raise (list s-type)) (contents s)) t))
+ (t #f))))
+ (let ((type-tags (map type-tag args)))
+ (let ((proc (get op type-tags)))
+ (if proc
+ (apply proc (map contents args))
+ (if (= (length args) 2)
+ (let ((o1 (car args))
+ (o2 (cadr args)))
+ (cond ((raise-into o1 o2)
+ (apply-generic-r op (raise-into o1 o2) o2))
+ ((raise-into o2 o1)
+ (apply-generic-r op o1 (raise-into o2 o1)))
+ (t (no-method type-tags))))
+ (no-method type-tags)))))
+
+(put 'project '(rational)
+ (lambda (r)
+ (make-scheme-number
+ (floor (/ (numer r) (denom r))))))
+(put 'project '(real)
+ (lambda (r)
+ (let ((scheme-rat
+ (rationalize
+ (inexact->exact r) 1/100)))
+ (make-rational (numerator scheme-rat)
+ (denominator scheme-rat)))))
+(put 'project '(complex)
+ (lambda (c) (make-real (real-part c))))
+
+(define (drop num)
+ (let ((project-proc
+ (get 'project (list (type-tag num)))))
+ (if project-proc
+ (let ((dropped (project-proc (contents num))))
+ (if (equ? num (raise dropped))
+ (drop dropped)
+ num))
+ num)))
+(define (apply-generic-r op . args)
+ (define (no-method type-tags)
+ (error "No method for these types"
+ (list op type-tags)))
+ (define (raise-into s t)
+ "Tries to raise s into the type of t. On success,
+ returns the raised s. Otherwise, returns #f"
+ (let ((s-type (type-tag s))
+ (t-type (type-tag t)))
+ (cond ((equal? s-type t-type) s)
+ ((get 'raise (list s-type))
+ (raise-into ((get 'raise (list s-type))
blob - /dev/null
blob + b0d98ad225e5eaa81d918bb6b6242c72266117e3 (mode 644)
--- /dev/null
+++ ex2-85-sol.scm~
+(define (install-rational-package)
+ (define (rational->integer r)
+ (make-integer (quotient (numer r) (denom r))))
+ (put-coercion 'rational 'integer rational->integer)
+ 'done)
+(define (install-real-package)
+ (define (real->rational r)
+ (make-rational (inexact->exact (numerator r))
+ (inexact->exact (denominator r))))
+ (put-coercion 'real 'rational real->rational)
+ 'done)
+(define (install-complex-package)
+ (define (complex->real z)
+ (make-real (complex-real-part z)))
+ (put-coercion 'complex 'real complex->real)
+ 'done)
+
+(define (apply-raise x types)
+ (cond ((null? types)
+ (error "Type not found in the tower-of-types"
+ (list (type-tag x) tower-of-types)))
+ ((eq? (type-tag x) (car types))
+ (if (null? (cdr types))
+ x
+ (let ((raiser (get-coercion (type-tag x) (cadr types))))
+ (if raiser
+ (raiser (contents x))
+ (error "No coercion procedure found for types"
+ (list (type-tag x) (cadr types)))))))
+ (else (apply-raise x (cdr types)))))
+(define (raise x)
+ (apply-raise x tower-of-types))
+(define (project x)
+ (apply-raise x (reverse tower-of-types)))
+(define (project x)
+ (define (apply-project types)
+ (cond ((eq? (type-tag x) (car types)) x)
+ ((or (null? types) (null? (cdr types)))
+ (error "type not found in the tower-of-types"
+ (list (type-tag x) tower-of-types)))
+ ((eq? (type-tag x) (cadr types))
+ (let ((projector (get-coercion (type-tag x) (car types))))
+ (if projector
+ (projector (contents x))
+ (error "No coercion procedure found for types"
+ (list (car types) (type-tag x))))))
+ (else (apply-project (cdr types)))))
+ (apply-project tower-of-types))
+
+
+(define (install-rational-package)
+ (define (rational->integer r)
+ (make-integer (round (/ (numer r) (denom r)))))
+ (put-coercion 'rational 'integer rational->integer)
+ 'done)
+
+(define (install-real-package)
+ (define (real->rational r)
+ (make-rational (inexact->exact (numerator r))
+ (inexact->exact (denominator r))))
+ (put-coercion 'real 'rational real->rational)
+ 'done)
+
+(define (install-complex-package)
+ (define (complex->real z)
+ (make-real (complex-real-part z)))
+ (put-coercion 'complex 'real complex->real)
+ 'done)
+
+(define (apply-raise x types)
+ (cond ((null? types)
+ (error "Type not found in the tower-of-types"
+ (list (type-tag x) tower-of-types)))
+ ((eq? (type-tag x) (car types))
+ (if (null? (cdr types))
+ x
+ (let ((raiser (get-coercion (type-tag x) (cadr types))))
+ (if raiser
+ (raiser (contents x))
+ (error "No coercion procedures found for types"
+ (list (type-tag x) (cadr types)))))))
+ (else (apply-raise x (cdr types)))))
+
+(define (raise x)
+ (apply-raise x tower-of-types))
+(define (project x)
+ (apply-raise x (reverse tower-of-types)))
+
+(define (project x)
+ (define (apply-project types)
+ (cond ((eq? (type-tag x) (car types)) x)
+ ((or (null? types) (null? (cdr types)))
+ (error "type not found in the tower-of-types"
+ (list (type-tag x) tower-of-types)))
blob - /dev/null
blob + d9ca5c7b503f33102ebca67eec162748e5350e11 (mode 644)
--- /dev/null
+++ ex2-85.scm
+(define (attach-tag type-tag contents)
+ (if (or (eq? type-tag 'integer)
+ (eq? type-tag 'real))
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((pair? datum) (car datum))
+ ((exact? datum) 'integer)
+ ((number? datum) 'real)
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((pair? datum) (cdr datum))
+ ((exact? datum) datum)
+ ((number? datum) (exact->inexact datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+(define (raise x) (apply-generic 'raise x))
+(define (project x) (apply-generic 'project x))
+
+
+(define (install-integer-package)
+ (define (tag x) (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (quotient x y))))
+ ;; (if (integer? (/ x y))
+ ;; (tag (/ x y))
+ ;; (div (raise (tag x))
+ ;; (raise (tag y))))))
+ ;; ;; we avoided calling make-rational to avoid dependencies
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) zero?)
+ (put 'make 'integer
+ (lambda (n)
+ (if (exact? n)
+ (tag n)
+ (error "Not an exact integer" n))))
+ (put 'raise '(integer)
+ (lambda (x) (make-rational x 1)))
+ (put 'project '(integer)
+ (lambda (x) #f))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (if (not (and (integer? n) (integer? d)))
+ (error "Both numerator and denominator must be integers"
+ (list n d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'raise '(rational)
+ (lambda (x) (make-real (/ (numer x) (denom x)))))
+ (put 'project '(rational)
+ (lambda (x) (make-integer (quotient (numer x) (denom x)))))
+ 'done)
+
+(define (install-real-package)
+ (define (tag x) (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real) zero?)
+ (put 'make 'real
+ (lambda (n)
+ (if (rational? n)
+ (tag (exact->inexact n))
+ (tag n))))
+ (put 'raise '(real)
+ (lambda (x) (make-complex-from-real-imag x 0)))
+ (put 'project '(real)
+ (lambda (x) (make-rational (inexact->exact (numerator x))
+ (inexact->exact (denominator x)))))
+ 'done)
+
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ (put 'project '(complex)
+ (lambda (z) (make-real (real-part z))))
+ 'done)
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-real n)
+ ((get 'make 'real) n))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; install number packages
+
+(install-integer-package)
+(install-rational-package)
+(install-real-package)
+(install-complex-package)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.85. This section mentioned a method for ``simplifying'' a data object by lowering it in the tower of types as far as possible.
+
+;; Design a procedure drop that accomplishes this for the tower described in exercise 2.83. The key is to decide, in some general way, whether an object can be lowered. For example, the complex number 1.5 + 0i can be lowered as far as real, the complex number 1 + 0i can be lowered as far as integer, and the complex number 2 + 3i cannot be lowered at all. Here is a plan for determining whether an object can be lowered:
+
+;; Begin by defining a generic operation project that ``pushes'' an object down in the tower. For example, projecting a complex number would involve throwing away the imaginary part. Then a number can be dropped if, when we project it and raise the result back to the type we started with, we end up with something equal to what we started with. Show how to implement this idea in detail, by writing a drop procedure that drops an object as far as possible. You will need to design the various projection operations and install project as a generic operation in the system. You will also need to make use of a generic equality predicate, such as described in exercise 2.79. Finally, use drop to rewrite apply-generic from exercise 2.84 so that it ``simplifies'' its answers.
+
+(define (drop x)
+ (let ((projected-x (project x)))
+ (if (and projected-x
+ (equ? x (raise projected-x)))
+ (drop projected-x)
+ x)))
+
+(test-case (drop (make-complex-from-mag-ang 5 0))
+ 5)
+(test-case (drop (make-rational 3 5))
+ '(rational 3 . 5))
+(test-case (drop (make-complex-from-real-imag 5/3 0))
+ '(rational 5 . 3))
+(test-case (drop (make-complex-from-mag-ang (sqrt 5) 0))
+ 2.23606797749979)
+
+(define (apply-generic op . args)
+ ;; return arg1 raised to same type as arg2, #f if not possible
+ (define (raise-to-second-type arg1 arg2)
+ (if (eq? (type-tag arg1) (type-tag arg2))
+ arg1
+ (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+ (if raise-proc
+ (raise-to-second-type (raise-proc (contents arg1)) arg2)
+ #f))))
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (drop (apply proc (map contents args)))
+ (if (= (length args) 2)
+ (let ((a1 (car args))
+ (a2 (cadr args)))
+ (if (eq? (type-tag a1) (type-tag a2))
+ (list "No method for these (raised) types" (list op type-tags))
+ (let ((raised1 (raise-to-second-type a1 a2))
+ (raised2 (raise-to-second-type a2 a1)))
+ (cond (raised1 (apply-generic op raised1 a2))
+ (raised2 (apply-generic op a1 raised2))
+ (else (list "No common supertype" (list op type-tags)))))))))))
+
+
+
+(test-case (add (make-integer 4) '(nonsense-type . 3))
+ '("No common supertype" (add (integer nonsense-type))))
+(test-case (apply-generic 'dummy (make-integer 3) (make-real 4.))
+ '("No method for these (raised) types" (dummy (real real))))
+(test-case (apply-generic 'dummy (make-real 4.) (make-integer 3))
+ '("No method for these (raised) types" (dummy (real real))))
+
+
+(test-case (add (make-integer 5) (make-rational 3 1))
+ (make-integer 8))
+(test-case (div (make-integer 2) (make-real 5))
+ (make-rational 2 5))
+(test-case (div (make-real 5) (make-integer 2))
+ (make-rationa 1 2))
+(test-case (mul (div (make-complex-from-mag-ang 3 2)
+ (make-integer 3))
+ (add (make-real 2.4)
+ (make-rational 4 3)))
+ '(complex polar 3.733333333334 . 2.))
+
+
+;; Of course, we should note that not all installed procedures return a tagged value. After all, we're using equ? as part of drop. So we should only apply drop to the result if we've got a tagged type. We can test that by checking to see if the result is a pair? whose car is in the tower-of-types.
+
+;; what happens when we are at the lowest rung in the tower of types? if we project then raise, do we end up with the lowest type or the second type? does this result in an infinite loop?
+
+;; use (rationalize (inexact->exact r) 1/100) to get 1/3 to rationalize properly
blob - /dev/null
blob + cdd461cfa7175a02b180e6a8b3479b8cfcaa62e7 (mode 644)
--- /dev/null
+++ ex2-85.scm~
+(define (attach-tag type-tag contents)
+ (if (or (eq? type-tag 'integer)
+ (eq? type-tag 'real))
+ contents
+ (cons type-tag contents)))
+(define (type-tag datum)
+ (cond ((pair? datum) (car datum))
+ ((exact? datum) 'integer)
+ ((number? datum) 'real)
+ ((error "error -- invalid datum" datum))))
+(define (contents datum)
+ (cond ((pair? datum) (cdr datum))
+ ((exact? datum) datum)
+ ((number? datum) (exact->inexact datum))
+ ((error "error -- invalid datum" datum))))
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (add x y) (apply-generic 'add x y))
+(define (sub x y) (apply-generic 'sub x y))
+(define (mul x y) (apply-generic 'mul x y))
+(define (div x y) (apply-generic 'div x y))
+(define (equ? x y) (apply-generic 'equ? x y))
+(define (=zero? x) (apply-generic '=zero? x))
+(define (raise x) (apply-generic 'raise x))
+(define (project x) (apply-generic 'project x))
+
+
+(define (install-integer-package)
+ (define (tag x) (attach-tag 'integer x))
+ (put 'add '(integer integer)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(integer integer)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(integer integer)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(integer integer)
+ (lambda (x y) (tag (quotient x y))))
+ ;; (if (integer? (/ x y))
+ ;; (tag (/ x y))
+ ;; (div (raise (tag x))
+ ;; (raise (tag y))))))
+ ;; ;; we avoided calling make-rational to avoid dependencies
+ (put 'equ? '(integer integer) =)
+ (put '=zero? '(integer) zero?)
+ (put 'make 'integer
+ (lambda (n)
+ (if (exact? n)
+ (tag n)
+ (error "Not an exact integer" n))))
+ (put 'raise '(integer)
+ (lambda (x) (make-rational x 1)))
+ (put 'project '(integer)
+ (lambda (x) #f))
+ 'done)
+
+(define (install-rational-package)
+ (define (gcd a b)
+ (if (= b 0)
+ a
+ (gcd b (remainder a b))))
+ (define (numer x) (car x))
+ (define (denom x) (cdr x))
+ (define (make-rat n d)
+ (if (not (and (integer? n) (integer? d)))
+ (error "Both numerator and denominator must be integers"
+ (list n d))
+ (let ((g (gcd n d)))
+ (cons (/ n g) (/ d g)))))
+ (define (add-rat x y)
+ (make-rat (+ (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (sub-rat x y)
+ (make-rat (- (* (numer x) (denom y))
+ (* (numer y) (denom x)))
+ (* (denom x) (denom y))))
+ (define (mul-rat x y)
+ (make-rat (* (numer x) (numer y))
+ (* (denom x) (denom y))))
+ (define (div-rat x y)
+ (make-rat (* (numer x) (denom y))
+ (* (denom x) (numer y))))
+ (define (equ-rat? x y)
+ (and (= (numer x) (numer y))
+ (= (denom x) (denom y))))
+ (define (=zero-rat? x) (= (numer x) 0))
+ (define (tag x) (attach-tag 'rational x))
+ (put 'add '(rational rational)
+ (lambda (x y) (tag (add-rat x y))))
+ (put 'sub '(rational rational)
+ (lambda (x y) (tag (sub-rat x y))))
+ (put 'mul '(rational rational)
+ (lambda (x y) (tag (mul-rat x y))))
+ (put 'div '(rational rational)
+ (lambda (x y) (tag (div-rat x y))))
+ (put 'equ? '(rational rational) equ-rat?)
+ (put '=zero? '(rational) =zero-rat?)
+ (put 'make 'rational
+ (lambda (n d) (tag (make-rat n d))))
+ (put 'raise '(rational)
+ (lambda (x) (make-real (/ (numer x) (denom x)))))
+ (put 'project '(rational)
+ (lambda (x) (make-integer (quotient (numer x) (denom x)))))
+ 'done)
+
+(define (install-real-package)
+ (define (tag x) (attach-tag 'real x))
+ (put 'add '(real real)
+ (lambda (x y) (tag (+ x y))))
+ (put 'sub '(real real)
+ (lambda (x y) (tag (- x y))))
+ (put 'mul '(real real)
+ (lambda (x y) (tag (* x y))))
+ (put 'div '(real real)
+ (lambda (x y) (tag (/ x y))))
+ (put 'equ? '(real real) =)
+ (put '=zero? '(real) zero?)
+ (put 'make 'real
+ (lambda (n)
+ (if (rational? n)
+ (tag (exact->inexact n))
+ (tag n))))
+ (put 'raise '(real)
+ (lambda (x) (make-complex-from-real-imag x 0)))
+ (put 'project '(real)
+ (lambda (x) (make-rational (inexact->exact (numerator x))
+ (inexact->exact (denominator x)))))
+ 'done)
+
+
+(define (install-complex-package)
+ (define (make-from-real-imag x y)
+ ((get 'make-from-real-imag 'rectangular) x y))
+ (define (make-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'polar) r a))
+
+ (define (real-part z) (apply-generic 'real-part z))
+ (define (imag-part z) (apply-generic 'imag-part z))
+ (define (magnitude z) (apply-generic 'magnitude z))
+ (define (angle z) (apply-generic 'angle z))
+
+ ;; rectangular and polar representations...
+
+ (define (install-complex-rectangular)
+ (define (make-from-real-imag-rectangular x y)
+ (cons x y))
+ (define (make-from-mag-ang-rectangular r a)
+ (cons (* r (cos a)) (* r (sin a))))
+ (define (real-part z) (car z))
+ (define (imag-part z) (cdr z))
+ (define (magnitude z)
+ (sqrt (+ (square (real-part z))
+ (square (imag-part z)))))
+ (define (angle z) (atan (imag-part z) (real-part z)))
+ (define (tag x) (attach-tag 'rectangular x))
+ (put 'real-part '(rectangular) real-part)
+ (put 'imag-part '(rectangular) imag-part)
+ (put 'magnitude '(rectangular) magnitude)
+ (put 'angle '(rectangular) angle)
+ (put 'make-from-real-imag 'rectangular
+ (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
+ (put 'make-from-mag-ang 'rectangular
+ (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
+ 'done)
+ (define (install-complex-polar)
+ (define (make-from-real-imag-polar x y)
+ (cons (sqrt (+ (square x) (square y)))
+ (atan y x)))
+ (define (make-from-mag-ang-polar r a)
+ (cons r a))
+ (define (real-part z) (* (magnitude z) (cos (angle z))))
+ (define (imag-part z) (* (magnitude z) (sin (angle z))))
+ (define (magnitude z) (car z))
+ (define (angle z) (cdr z))
+ (define (tag x) (attach-tag 'polar x))
+ (put 'real-part '(polar) real-part)
+ (put 'imag-part '(polar) imag-part)
+ (put 'magnitude '(polar) magnitude)
+ (put 'angle '(polar) angle)
+ (put 'make-from-real-imag 'polar
+ (lambda (x y) (tag (make-from-real-imag-polar x y))))
+ (put 'make-from-mag-ang 'polar
+ (lambda (r a) (tag (make-from-mag-ang-polar r a))))
+ 'done)
+ (install-complex-rectangular)
+ (install-complex-polar)
+ ;; end rectangular and polar representations
+
+ (define (add-complex z1 z2)
+ (make-from-real-imag (+ (real-part z1) (real-part z2))
+ (+ (imag-part z1) (imag-part z2))))
+ (define (sub-complex z1 z2)
+ (make-from-real-imag (- (real-part z1) (real-part z2))
+ (- (imag-part z1) (imag-part z2))))
+ (define (mul-complex z1 z2)
+ (make-from-mag-ang (* (magnitude z1) (magnitude z2))
+ (+ (angle z1) (angle z2))))
+ (define (div-complex z1 z2)
+ (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
+ (- (angle z1) (angle z2))))
+ (define (equ-complex? z1 z2)
+ (or (and (= (real-part z1) (real-part z2))
+ (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
+ (and (= (magnitude z1) (magnitude z2))
+ (= (angle z1) (angle z2)))))
+ (define (=zero-complex? z)
+ (and (= (real-part z) 0)
+ (= (imag-part z) 0)))
+
+ (define (tag x) (attach-tag 'complex x))
+ (put 'add '(complex complex)
+ (lambda (z1 z2) (tag (add-complex z1 z2))))
+ (put 'sub '(complex complex)
+ (lambda (z1 z2) (tag (sub-complex z1 z2))))
+ (put 'mul '(complex complex)
+ (lambda (z1 z2) (tag (mul-complex z1 z2))))
+ (put 'div '(complex complex)
+ (lambda (z1 z2) (tag (div-complex z1 z2))))
+ (put 'equ? '(complex complex) equ-complex?)
+ (put '=zero? '(complex) =zero-complex?)
+ (put 'make-from-real-imag 'complex
+ (lambda (x y) (tag (make-from-real-imag x y))))
+ (put 'make-from-mag-ang 'complex
+ (lambda (r a) (tag (make-from-mag-ang r a))))
+ (put 'project '(complex)
+ (lambda (z) (make-real (real-part z))))
+ 'done)
+
+(define (make-integer n)
+ ((get 'make 'integer) n))
+(define (make-rational n d)
+ ((get 'make 'rational) n d))
+(define (make-real n)
+ ((get 'make 'real) n))
+(define (make-complex-from-real-imag x y)
+ ((get 'make-from-real-imag 'complex) x y))
+(define (make-complex-from-mag-ang r a)
+ ((get 'make-from-mag-ang 'complex) r a))
+
+;; install number packages
+
+(install-integer-package)
+(install-rational-package)
+(install-real-package)
+(install-complex-package)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 2.85. This section mentioned a method for ``simplifying'' a data object by lowering it in the tower of types as far as possible.
+
+;; Design a procedure drop that accomplishes this for the tower described in exercise 2.83. The key is to decide, in some general way, whether an object can be lowered. For example, the complex number 1.5 + 0i can be lowered as far as real, the complex number 1 + 0i can be lowered as far as integer, and the complex number 2 + 3i cannot be lowered at all. Here is a plan for determining whether an object can be lowered:
+
+;; Begin by defining a generic operation project that ``pushes'' an object down in the tower. For example, projecting a complex number would involve throwing away the imaginary part. Then a number can be dropped if, when we project it and raise the result back to the type we started with, we end up with something equal to what we started with. Show how to implement this idea in detail, by writing a drop procedure that drops an object as far as possible. You will need to design the various projection operations and install project as a generic operation in the system. You will also need to make use of a generic equality predicate, such as described in exercise 2.79. Finally, use drop to rewrite apply-generic from exercise 2.84 so that it ``simplifies'' its answers.
+
+(define (drop x)
+ (let ((projected-x (project x)))
+ (if (and projected-x
+ (equ? x (raise projected-x)))
+ (drop projected-x)
+ x)))
+
+(test-case (drop (make-complex-from-mag-ang 5 0))
+ 5)
+(test-case (drop (make-rational 3 5))
+ '(rational 3 . 5))
+(test-case (drop (make-complex-from-real-imag 5/3 0))
+ '(rational 5 . 3))
+(test-case (drop (make-complex-from-mag-ang (sqrt 5) 0))
+ 2.23606797749979)
+
+(define (apply-generic op . args)
+ ;; return arg1 raised to same type as arg2, #f if not possible
+ (define (raise-to-second-type arg1 arg2)
+ (if (eq? (type-tag arg1) (type-tag arg2))
+ arg1
+ (let ((raise-proc (get 'raise (list (type-tag arg1)))))
+ (if raise-proc
+ (raise-to-second-type (raise-proc (contents arg1)) arg2)
+ #f))))
+ (let* ((type-tags (map type-tag args))
+ (proc (get op type-tags)))
+ (if proc
+ (drop (apply proc (map contents args)))
+ (if (= (length args) 2)
+ (let ((a1 (car args))
+ (a2 (cadr args)))
+ (if (eq? (type-tag a1) (type-tag a2))
+ (list "No method for these (raised) types" (list op type-tags))
+ (let ((raised1 (raise-to-second-type a1 a2))
+ (raised2 (raise-to-second-type a2 a1)))
+ (cond (raised1 (apply-generic op raised1 a2))
+ (raised2 (apply-generic op a1 raised2))
+ (else (list "No common supertype" (list op type-tags)))))))))))
+
+
+
+(test-case (add (make-integer 4) '(nonsense-type . 3))
+ '("No common supertype" (add (integer nonsense-type))))
+(test-case (apply-generic 'dummy (make-integer 3) (make-real 4.))
+ '("No method for these (raised) types" (dummy (real real))))
+(test-case (apply-generic 'dummy (make-real 4.) (make-integer 3))
+ '("No method for these (raised) types" (dummy (real real))))
+
+
+(test-case (add (make-integer 5) (make-rational 3 1))
+ (make-integer 8))
+(test-case (div (make-integer 2) (make-real 5))
+ (make-rational 2 5))
+(test-case (div (make-real 5) (make-integer 2))
+ (make-rationa 1 2))
+(test-case (mul (div (make-complex-from-mag-ang 3 2)
+ (make-integer 3))
+ (add (make-real 2.4)
+ (make-rational 4 3)))
+ '(complex polar 3.733333333334 . 2.))
blob - /dev/null
blob + 944f1bf941ed82b4f8b89d4841370c865ff3a39a (mode 644)
--- /dev/null
+++ ex2-9.scm
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+(define (mul-interval x y)
+ (let ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (div-interval x y)
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+;; Exercise 2.9. The width of an interval is half of the difference between its upper and lower bounds. The width is a measure of the uncertainty of the number specified by the interval. For some arithmetic operations the width of the result of combining two intervals is a function only of the widths of the argument intervals, whereas for others the width of the combination is not a function of the widths of the argument intervals. Show that the width of the sum (or difference) of two intervals is a function only of the widths of the intervals being added (or subtracted). Give examples to show that this is not true for multiplication or division.
+
+;; width of addition/subtraction is just the sum of the two widths
+
+(define i1 (make-interval -3 4))
+(define i2 (make-interval -7 -3))
+
+;; (width (mul-interval i1 i2)) is equal to 33/2; the two original widths were 7/2 and 4/2
+
+(define i3 (make-interval 3 4))
+(define i4 (make-interval 15 20))
+
+;; (width (mul-interval i3 i4)) is equal to 35/2; the two original widths were 1/2 and 5/2
+
+;; even though the widths of i1 and i2 were originally greater, their resulting product's width is smaller than i3 and i4's product's width
+
blob - /dev/null
blob + 727ce7af88bb53e78e35b53a5ec0de7e74681bd0 (mode 644)
--- /dev/null
+++ ex2-9.scm~
+(define (add-interval x y)
+ (make-interval (+ (lower-bound x) (lower-bound y))
+ (+ (upper-bound x) (upper-bound y))))
+(define (mul-interval x y)
+ (let ((p1 (* (lower-bound x) (lower-bound y)))
+ (p2 (* (lower-bound x) (upper-bound y)))
+ (p3 (* (upper-bound x) (lower-bound y)))
+ (p4 (* (upper-bound x) (upper-bound y))))
+ (make-interval (min p1 p2 p3 p4)
+ (max p1 p2 p3 p4))))
+
+(define (div-interval x y)
+ (mul-interval x
+ (make-interval (/ 1.0 (upper-bound y))
+ (/ 1.0 (lower-bound y)))))
+
+(define (make-interval lower upper)
+ (cons lower upper))
+(define (upper-bound interval)
+ (cdr interval))
+(define (lower-bound interval)
+ (car interval))
+
+
+;; Exercise 2.8. Using reasoning analogous to Alyssa's, describe how the difference of two intervals may be computed. Define a corresponding subtraction procedure, called sub-interval.
+
+(define (sub-interval x y)
+ (make-interval (- (lower-bound x) (upper-bound y))
+ (- (upper-bound x) (lower-bound y))))
+
+;; Exercise 2.9. The width of an interval is half of the difference between its upper and lower bounds. The width is a measure of the uncertainty of the number specified by the interval. For some arithmetic operations the width of the result of combining two intervals is a function only of the widths of the argument intervals, whereas for others the width of the combination is not a function of the widths of the argument intervals. Show that the width of the sum (or difference) of two intervals is a function only of the widths of the intervals being added (or subtracted). Give examples to show that this is not true for multiplication or division.
blob - /dev/null
blob + e4b6c932b15ebba18fc007cdbb4ac5ce7538f74a (mode 644)
--- /dev/null
+++ ex3-12.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(define x (list 'a 'b))
+(define y (list 'c 'd))
+(define z (append x y))
+(test-case z '(a b c d))
+(test-case (cdr x) '(b))
+(define w (append! x y))
+(test-case w '(a b c d))
+(test-case (cdr x) '(b c d))
blob - /dev/null
blob + c1fe8a5879a77aad8d3a2818be5cd80d12770e85 (mode 644)
--- /dev/null
+++ ex3-12.scm~
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(define x (list 'a 'b))
+(define y (list 'c 'd))
+(define z (append x y))
+z
+(a b c d)
+(cdr x)
+<response>
+(define w (append! x y))
+w
+(a b c d)
+(cdr x)
+<response>
+p
+What are the missing <response>s? Draw box-and-pointer diagrams to explain your answer.
blob - /dev/null
blob + 6f02e3979c40190b56b77d038302cca321f0ca81 (mode 644)
--- /dev/null
+++ ex3-13.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(define (make-cycle x)
+ (set-cdr! (last-pair x) x)
+ x)
+
+(define z (make-cycle (list 'a 'b 'c)))
+
+;; What happens if we try to compute (last-pair z)?
+
+;; infinite loop
blob - /dev/null
blob + f1d8a598a39639b6d08ce871f434c66f6431df7f (mode 644)
--- /dev/null
+++ ex3-13.scm~
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(define (make-cycle x)
+ (set-cdr! (last-pair x) x)
+ x)
+
+Draw a box-and-pointer diagram that shows the structure z created by
+
+(define z (make-cycle (list 'a 'b 'c)))
+
+What happens if we try to compute (last-pair z)?
blob - /dev/null
blob + ab27dc2dc021039cdd37e6590206a5d801f292cd (mode 644)
--- /dev/null
+++ ex3-14.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (mystery x)
+ (define (loop x y)
+ (if (null? x)
+ y
+ (let ((temp (cdr x)))
+ (set-cdr! x y)
+ (loop temp x))))
+ (loop x '()))
+
+;; Explain what mystery does in general.
+
+;; mystery reverses the list x
+
+(define v (list 'a 'b 'c 'd))
+
+(define w (mystery v))
+(test-case v '(a))
+(test-case w '(d c b a))
+
blob - /dev/null
blob + 43e2485c3f37c67dfc2bf44a04b4015511251d18 (mode 644)
--- /dev/null
+++ ex3-14.scm~
+(define (mystery x)
+ (define (loop x y)
+ (if (null? x)
+ y
+ (let ((temp (cdr x)))
+ (set-cdr! x y)
+ (loop temp x))))
+ (loop x '()))
+
+Loop uses the ``temporary'' variable temp to hold the old value of the cdr of x, since the set-cdr! on the next line destroys the cdr. Explain what mystery does in general. Suppose v is defined by (define v (list 'a 'b 'c 'd)). Draw the box-and-pointer diagram that represents the list to which v is bound. Suppose that we now evaluate (define w (mystery v)). Draw box-and-pointer diagrams that show the structures v and w after evaluating this expression. What would be printed as the values of v and w ?
blob - /dev/null
blob + 31c16435098b87afe44c71b6be91c0c185927161 (mode 644)
--- /dev/null
+++ ex3-16.lisp
+(defun bad-count-pairs (x)
+ (if (not (consp x))
+ 0
+ (+ (bad-count-pairs (car x))
+n (bad-count-pairs (cdr x))
+ 1)))
+(defvar z '(a b c))
+(bad-count-pairs z)
+(setf (car (cdr z)) (cddr z))
+(bad-count-pairs z)
+(setf (car z) (cdr z))
+(bad-count-pairs z)
+(setf (car z) z)
+(bad-count-pairs z)
blob - /dev/null
blob + 702216fb0e7093d693c3b32c846462896590f0e6 (mode 644)
--- /dev/null
+++ ex3-16.lisp~
+(defun bad-count-pairs (x)
+ (if (not (consp x))
+ 0
+ (+ (bad-count-pairs (car x))
+ (bad-count-pairs (cdr x))
+ 1)))
blob - /dev/null
blob + c56b24af97e5795ee0482d5b89605c4a4bbd478a (mode 644)
--- /dev/null
+++ ex3-16.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(define (make-cycle x)
+ (set-cdr! (last-pair x) x)
+ x)
+
+(define (count-pairs x)
+ (if (not (pair? x))
+ 0
+ (+ (count-pairs (car x))
+ (count-pairs (cdr x))
+ 1)))
+
+(define three '(a b c))
+(define a-pair (cons '() '()))
+(define b-pair (cons a-pair a-pair))
+(define four (cons 'a b-pair))
+(define seven (cons b-pair b-pair))
+(define circular (make-cycle '(a b c)))
+
+(test-case (count-pairs three) 3)
+(test-case (count-pairs four) 4)
+(test-case (count-pairs seven) 7)
+(test-case (count-pairs circular) 'infinite-loop)
blob - /dev/null
blob + 460ca047b162329ba6d68472b352372410b18d38 (mode 644)
--- /dev/null
+++ ex3-16.scm~
+;; Devise a correct version of the count-pairs procedure of exercise 3.16 that returns the number of distinct pairs in any structure. (Hint: Traverse the structure, maintaining an auxiliary data structure that is used to keep track of which pairs have already been counted.)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (count-pairs x)
+ (if (not (pair? x))
+ 0
+ (+ (count-pairs (car x))
+ (count-pairs (cdr x))
+ 1)))
+
+(define three '(a b c))
+(define four )
+(define seven )
+(define circular )
+
blob - /dev/null
blob + 57452a6f657b5cd3dcf679e5dff4b34438760409 (mode 644)
--- /dev/null
+++ ex3-17.lisp
+(defun good-count-pairs (x)
+ (let ((pairs-table (make-hash-table :test #'eq)))
+ (labels (
+ (traverse-count (x)
+ (cond
+ ((not (consp x)) 0)
+ ((gethash x pairs-table) 0)
+ (t
+ (setf (gethash x pairs-table) 1)
+ (+ (traverse-count (car x))
+ (traverse-count (cdr x))
+ 1)))))
+ (traverse-count x))))
blob - /dev/null
blob + 13693c507e85d75e4be942b99c5c742a54de150b (mode 644)
--- /dev/null
+++ ex3-17.lisp~
+(defun good-count-pairs (x)
+ (let ((pairs-table (make-hash-table :test #'eq)))
blob - /dev/null
blob + 0b2d6b23f6dd3ed9fadc5b2588a3f86fdc9c7c0c (mode 644)
--- /dev/null
+++ ex3-17.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (wrong-count-pairs x)
+ (if (not (pair? x))
+ 0
+ (+ (count-pairs (car x))
+ (count-pairs (cdr x))
+ 1)))
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(define (make-cycle x)
+ (set-cdr! (last-pair x) x)
+ x)
+
+(define three '(a b c))
+(define a-pair (cons '() '()))
+(define b-pair (cons a-pair a-pair))
+(define four (cons 'a b-pair))
+(define seven (cons b-pair b-pair))
+(define circular (make-cycle '(a b c)))
+
+;; (test-case (wrong-count-pairs three) 3)
+;; (test-case (wrong-count-pairs four) 4)
+;; (test-case (wrong-count-pairs seven) 7)
+;; (test-case (wrong-count-pairs circular) 'infinite-loop)
+
+;; Devise a correct version of the count-pairs procedure of exercise 3.16 that returns the number of distinct pairs in any structure. (Hint: Traverse the structure, maintaining an auxiliary data structure that is used to keep track of which pairs have already been counted.)
+
+(define (count-pairs x)
+ (let ((traversed-pairs '()))
+ (define (not-traversed x)
+ (cond ((not (pair? x)) 0)
+ ((memq x traversed-pairs) 0)
+ (else (set! traversed-pairs (cons x traversed-pairs))
+ (+ (not-traversed (car x))
+ (not-traversed (cdr x))
+ 1))))
+ (not-traversed x)))
+
+(test-case (count-pairs three) 3)
+(test-case (count-pairs four) 3)
+(test-case (count-pairs seven) 3)
+(test-case (count-pairs circular) 3)
+
blob - /dev/null
blob + 460ca047b162329ba6d68472b352372410b18d38 (mode 644)
--- /dev/null
+++ ex3-17.scm~
+;; Devise a correct version of the count-pairs procedure of exercise 3.16 that returns the number of distinct pairs in any structure. (Hint: Traverse the structure, maintaining an auxiliary data structure that is used to keep track of which pairs have already been counted.)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (count-pairs x)
+ (if (not (pair? x))
+ 0
+ (+ (count-pairs (car x))
+ (count-pairs (cdr x))
+ 1)))
+
+(define three '(a b c))
+(define four )
+(define seven )
+(define circular )
+
blob - /dev/null
blob + c30e36488a927ab3d942d39bd7d43f5e53fab2e5 (mode 644)
--- /dev/null
+++ ex3-18-2.scm
+(define (cycle? x)
+ (let ((aux '()))
+ (define (find-cycle z)
+ (cond ((null? z) false)
+ ((memq z aux) true)
+ (else
+ (set-cdr! (last-pair aux) (list z))
+ (find-cycle (cdr z)))))
+ (if (not (pair? x))
+ (error "argument of cycle? must be a pair."))
+ (set! aux (list x))
+ (find-cycle (cdr x))))
blob - /dev/null
blob + 206cb133299997ac306a03b3ab774dc9a24ca07a (mode 644)
--- /dev/null
+++ ex3-18.lisp
+(defun has-loop? (x)
+ (let ((pairs-table (make-hash-table :test #'eq)))
+ (labels (
+ (traverse-list (x)
+ (cond
+ ((null x) nil)
+ ((gethash x pairs-table) t)
+ (t
+ (setf (gethash x pairs-table) 1)
+ (traverse-list (cdr x))))))
+ (traverse-list x))))
blob - /dev/null
blob + 1e2f5a73ecc174ec33d66c93c2083cfec69d8b2e (mode 644)
--- /dev/null
+++ ex3-18.scm
+;; Exercise 3.18. Write a procedure that examines a list and determines whether it contains a cycle, that is, whether a program that tried to find the end of the list by taking successive cdrs would go into an infinite loop. Exercise 3.13 constructed such lists.
+
+(define (cycle? l)
+ (let ((traversed '()))
+ (define (not-all-unique? l)
+ (cond ((not (pair? l)) #f)
+ ((memq l traversed) #t)
+ (else (set! traversed (cons l traversed))
+ (not-all-unique? (cdr l)))))
+ (not-all-unique? l)))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(define (make-cycle x)
+ (set-cdr! (last-pair x) x)
+ x)
+
+(define three '(a b c))
+(define a-pair (cons '() '()))
+(define b-pair (cons a-pair a-pair))
+(define four (cons 'a b-pair))
+(define seven (cons b-pair b-pair))
+(define circular (make-cycle '(a b c)))
+
+(test-case (cycle? three) #f)
+(test-case (cycle? four) #f)
+(test-case (cycle? seven) #f)
+(test-case (cycle? circular) #t)
blob - /dev/null
blob + 731e0e2a08830eb33d35bffec2ca517010e94389 (mode 644)
--- /dev/null
+++ ex3-18.scm~
+ Exercise 3.18. Write a procedure that examines a list and determines whether it contains a cycle, that is, whether a program that tried to find the end of the list by taking successive cdrs would go into an infinite loop. Exercise 3.13 constructed such lists.
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(define (make-cycle x)
+ (set-cdr! (last-pair x) x)
+ x)
+
+(define (count-pairs x)
+ (if (not (pair? x))
+ 0
+ (+ (count-pairs (car x))
+ (count-pairs (cdr x))
+ 1)))
+
+(define three '(a b c))
+(define a-pair (cons '() '()))
+(define b-pair (cons a-pair a-pair))
+(define four (cons 'a b-pair))
+(define seven (cons b-pair b-pair))
+(define circular (make-cycle '(a b c)))
+
+(test-case (count-pairs three) 3)
+(test-case (count-pairs four) 4)
+(test-case (count-pairs seven) 7)
+(test-case (count-pairs circular) 'infinite-loop)
blob - /dev/null
blob + 2c71f7e62b9d858b7f04fad4959860767ef5459e (mode 644)
--- /dev/null
+++ ex3-19-2.scm
+(define (cycle? x)
+ (define (compare end-index current-index z current-list)
+ (cond ((eq? end-index current-index) false)
+ ((eq? current-list z) true)
+ (else (compare end-index
+ (+ 1 current-index)
+ z
+ (cdr current-list)))))
+ (define (find-cycle z i)
+ (cond ((null? z) false)
+ ((compare i 0 z x) true)
+ (else (find-cycle (cdr z) (+ 1 i)))))
+ (if (not (pair? x))
+ (error "Argument of cycle? must be a pair")
+ (find cycle (cdr x) 1)))
blob - /dev/null
blob + 286ba3c14a61e7e71825e5615863453a95fc3fa1 (mode 644)
--- /dev/null
+++ ex3-19.lisp
+(defun has-loop-O1space? (x)
+ (do ( (iter-1 (cdr x) (cdr iter-1))
+ (iter-2 (cddr x) (cddr iter-2)))
+ ((null iter-2) nil)
+ (when (eq iter-1 iter-2)
+ (return t))))
blob - /dev/null
blob + 3ef9b8ccdac898b275e8c10bdb5e75c69bc7624f (mode 644)
--- /dev/null
+++ ex3-19.scm
+;; Exercise 3.19. Redo exercise 3.18 using an algorithm that takes only a constant amount of space. (This requires a very clever idea.)
+
+;; Exercise 3.18. Write a procedure that examines a list and determines whether it contains a cycle, that is, whether a program that tried to find the end of the list by taking successive cdrs would go into an infinite loop. Exercise 3.13 constructed such lists.
+
+;; (define (cycle? l)
+;; (let ((traversed '()))
+;; (define (not-all-unique? l)
+;; (cond ((not (pair? l)) #f)
+;; ((memq l traversed) #t)
+;; (else (set! traversed (cons l traversed))
+;; (not-all-unique? (cdr l)))))
+;; (not-all-unique? l)))
+
+;; (define (cycle? l)
+;; (define (iter single double)
+;; (if (eq? single double)
+;; #t
+;; (if (and (pair? double)
+;; (pair? (cdr double)))
+;; (iter (cdr single) (cddr double))
+;; #f)))
+;; (if (pair? l)
+;; (iter l (cdr l))
+;; #f))
+
+(define (cycle? l)
+ (define (loop? single double)
+ (or (eq? single double)
+ (and (pair? double)
+ (pair? (cdr double))
+ (loop? (cdr single) (cddr double)))))
+ (and (pair? l)
+ (loop? l (cdr l))))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(define (make-cycle x)
+ (set-cdr! (last-pair x) x)
+ x)
+
+(define three '(a b c))
+(define a-pair (cons '() '()))
+(define b-pair (cons a-pair a-pair))
+(define four (cons 'a b-pair))
+(define seven (cons b-pair b-pair))
+(define circular (make-cycle '(a b c)))
+(define circular-car (cons circular '()))
+(define circular-cdr (cons '() circular))
+
+(test-case (cycle? three) #f)
+(test-case (cycle? four) #f)
+(test-case (cycle? seven) #f)
+(test-case (cycle? circular) #t)
+(test-case (cycle? circular-car) #f) ;; because you can cdr to the end
+(test-case (cycle? circular-cdr) #t)
blob - /dev/null
blob + 1dacb5f004318586ad2945121973e7cb5d9397a3 (mode 644)
--- /dev/null
+++ ex3-19.scm~
+ Exercise 3.19. Redo exercise 3.18 using an algorithm that takes only a constant amount of space. (This requires a very clever idea.)
+
+
+;; Exercise 3.18. Write a procedure that examines a list and determines whether it contains a cycle, that is, whether a program that tried to find the end of the list by taking successive cdrs would go into an infinite loop. Exercise 3.13 constructed such lists.
+
+(define (cycle? l)
+ (let ((traversed '()))
+ (define (not-all-unique? l)
+ (cond ((not (pair? l)) #f)
+ ((memq l traversed) #t)
+ (else (set! traversed (cons l traversed))
+ (not-all-unique? (cdr l)))))
+ (not-all-unique? l)))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(define (make-cycle x)
+ (set-cdr! (last-pair x) x)
+ x)
+
+(define three '(a b c))
+(define a-pair (cons '() '()))
+(define b-pair (cons a-pair a-pair))
+(define four (cons 'a b-pair))
+(define seven (cons b-pair b-pair))
+(define circular (make-cycle '(a b c)))
+
+(test-case (cycle? three) #f)
+(test-case (cycle? four) #f)
+(test-case (cycle? seven) #f)
+(test-case (cycle? circular) #t)
blob - /dev/null
blob + 3283958159ad1fd33e93b645112cf9e7544b443b (mode 644)
--- /dev/null
+++ ex3-20.scm
+(define (cons x y)
+ (define (set-x! v) (set! x v))
+ (define (set-y! v) (set! y v))
+ (define (dispatch m)
+ (cond ((eq? m 'car) x)
+ ((eq? m 'cdr) y)
+ ((eq? m 'set-car!) set-x!)
+ ((eq? m 'set-cdr!) set-y!)
+ (else (error "Undefined operation -- CONS" m))))
+ dispatch)
+(define (car z) (z 'car))
+(define (cdr z) (z 'cdr))
+(define (set-car! z new-value)
+ ((z 'set-car!) new-value)
+ z)
+(define (set-cdr! z new-value)
+ ((z 'set-cdr!) new-value)
+ z)
+
+;; Exercise 3.20. Draw environment diagrams to illustrate the evaluation of the sequence of expressions
+
+(define x (cons 1 2))
+(define z (cons x x))
+(set-car! (cdr z) 17)
+(car x)
+17
+
blob - /dev/null
blob + d64fb71679a0879c9f6d570b9ce8f57928eeaa9a (mode 644)
--- /dev/null
+++ ex3-20.scm~
+(define (cons x y)
+ (define (set-x! v) (set! x v))
+ (define (set-y! v) (set! y v))
+ (define (dispatch m)
+ (cond ((eq? m 'car) x)
+ ((eq? m 'cdr) y)
+ ((eq? m 'set-car!) set-x!)
+ ((eq? m 'set-cdr!) set-y!)
+ (else (error "Undefined operation -- CONS" m))))
+ dispatch)
+(define (car z) (z 'car))
+(define (cdr z) (z 'cdr))
+(define (set-car! z new-value)
+ ((z 'set-car!) new-value)
+ z)
+(define (set-cdr! z new-value)
+ ((z 'set-cdr!) new-value)
+ z)
+
+Assignment is all that is needed, theoretically, to account for the behavior of mutable data. As soon as we admit set! to our language, we raise all the issues, not only of assignment, but of mutable data in general.21
+
+Exercise 3.20. Draw environment diagrams to illustrate the evaluation of the sequence of expressions
+
+(define x (cons 1 2))
+(define z (cons x x))
+(set-car! (cdr z) 17)
+(car x)
+17
+
blob - /dev/null
blob + 14df911c0956b0d53363d3d65d7c946cf35cbd1a (mode 644)
--- /dev/null
+++ ex3-21.scm
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (make-queue) (cons '() '()))
+(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+;; Exercise 3.21
+
+;; Define a procedure print-queue that takes a queue as input and prints the sequence of items in the queue.
+
+(define (print-queue queue)
+ (newline)
+ (newline)
+ (display (front-ptr queue))
+ (newline)
+ (front-ptr queue))
+
+(define q (make-queue))
+(insert-queue! q 'a)
+(test-case (print-queue q) '(a))
+(insert-queue! q 'b)
+(test-case (print-queue q) '(a b))
+(insert-queue! q 'c)
+(test-case (print-queue q) '(a b c))
+(insert-queue! q 'd)
+(test-case (print-queue q) '(a b c d))
+(insert-queue! q 'e)
+(test-case (print-queue q) '(a b c d e))
+(delete-queue! q)
+(test-case (print-queue q) '(b c d e))
+(delete-queue! q)
+(test-case (print-queue q) '(c d e))
+
blob - /dev/null
blob + 8dfc5d52c8d15106449fb593077f57af33ea9333 (mode 644)
--- /dev/null
+++ ex3-21.scm~
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (make-queue) (cons '() '()))
+(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
blob - /dev/null
blob + 2bbc3b6689bb23ae7898aca33140a0c8244ec2d7 (mode 644)
--- /dev/null
+++ ex3-22-2.scm
+;; Exercise 3.22. Instead of representing a queue as a pair of pointers, we can build a queue as a procedure with local state. The local state will consist of pointers to the beginning and the end of an ordinary list. Thus, the make-queue procedure will have the form
+
+;; it's better to hide front-ptr, rear-ptr, set-front-ptr!, and set-rear-ptr! since these are really implementation details
+
+(define (make-queue)
+ (let ((front-ptr '())
+ (rear-ptr '()))
+ (define (empty-queue?)
+ (null? front-ptr))
+ (define (front-queue)
+ (if (empty-queue?)
+ (error "FRONT called with an empty queue" dispatch)
+ (car front-ptr)))
+ (define (insert-queue! item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue?)
+ (set! front-ptr new-pair)
+ (set! rear-ptr new-pair))
+ (else
+ (set-cdr! rear-ptr new-pair)
+ (set! rear-ptr new-pair)))
+ dispatch))
+ (define (delete-queue!)
+ (cond ((empty-queue?)
+ (error "DELETE! called with an empty queue" dispatch))
+ (else
+ (set! front-ptr (cdr front-ptr))
+ dispatch)))
+ (define (dispatch m)
+ (cond ((eq? m 'empty-queue?) (empty-queue?))
+ ((eq? m 'front-queue) (front-queue))
+ ((eq? m 'insert-queue!) insert-queue!)
+ ((eq? m 'delete-queue!) (delete-queue!))
+ ((eq? m 'queue->list) front-ptr)
+ (else (error "undefined operation -- MAKE-QUEUE" m))))
+ dispatch))
+
+;; publicly visible interface
+
+(define (empty-queue? queue)
+ (queue 'empty-queue?))
+(define (front-queue queue)
+ (queue 'front-queue))
+(define (insert-queue! queue item)
+ ((queue 'insert-queue!) item))
+(define (delete-queue! queue)
+ (queue 'delete-queue!))
+(define (queue->list queue)
+ (queue 'queue->list))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 3.21
+
+;; Define a procedure print-queue that takes a queue as input and prints the sequence of items in the queue.
+
+(define (print-queue queue)
+ (newline)
+ (newline)
+ (display (queue->list queue))
+ (newline)
+ (queue->list queue))
+
+(define q (make-queue))
+(insert-queue! q 'a)
+(test-case (print-queue q) '(a))
+(insert-queue! q 'b)
+(test-case (print-queue q) '(a b))
+(insert-queue! q 'c)
+(test-case (print-queue q) '(a b c))
+(insert-queue! q 'd)
+(test-case (print-queue q) '(a b c d))
+(insert-queue! q 'e)
+(test-case (print-queue q) '(a b c d e))
+(delete-queue! q)
+(test-case (print-queue q) '(b c d e))
+(delete-queue! q)
+(test-case (print-queue q) '(c d e))
blob - /dev/null
blob + bcb7bd29581899eed3c9fa24f3bf416a52f755af (mode 644)
--- /dev/null
+++ ex3-22-2.scm~
+;; Exercise 3.22. Instead of representing a queue as a pair of pointers, we can build a queue as a procedure with local state. The local state will consist of pointers to the beginning and the end of an ordinary list. Thus, the make-queue procedure will have the form
+
+(define (make-queue)
+ (let ((front-ptr '())
+ (rear-ptr '()))
+ (define (set-front-ptr! item)
+ (set! front-ptr item))
+ (define (set-rear-ptr! item)
+ (set! rear-ptr item))
+ (define (dispatch m)
+ (cond ((eq? m 'front-ptr) front-ptr)
+ ((eq? m 'rear-ptr) rear-ptr)
+ ((eq? m 'set-front-ptr!) set-front-ptr!)
+ ((eq? m 'set-rear-ptr!) set-rear-ptr!)))
+ dispatch))
+
+;; Complete the definition of make-queue andprovide implementations of the queue operations using this representation.
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; the four basic accessor/setter methods
+
+(define (front-ptr queue) (queue 'front-ptr))
+(define (rear-ptr queue) (queue 'rear-ptr))
+(define (set-front-ptr! queue item)
+ ((queue 'set-front-ptr!) item))
+(define (set-rear-ptr! queue item)
+ ((queue 'set-rear-ptr!) item))
+
+;; the rest remain untouched
+
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+;; Exercise 3.21
+
+;; Define a procedure print-queue that takes a queue as input and prints the sequence of items in the queue.
+
+(define (print-queue queue)
+ (newline)
+ (newline)
+ (display (front-ptr queue))
+ (newline)
+ (front-ptr queue))
+
+(define q (make-queue))
+(insert-queue! q 'a)
+(test-case (print-queue q) '(a))
+(insert-queue! q 'b)
+(test-case (print-queue q) '(a b))
+(insert-queue! q 'c)
+(test-case (print-queue q) '(a b c))
+(insert-queue! q 'd)
+(test-case (print-queue q) '(a b c d))
+(insert-queue! q 'e)
+(test-case (print-queue q) '(a b c d e))
+(delete-queue! q)
+(test-case (print-queue q) '(b c d e))
+(delete-queue! q)
+(test-case (print-queue q) '(c d e))
+
+
+ ;; (define (empty-queue?)
+ ;; (null? front-ptr))
+ ;; (define (set-front-ptr! item)
+ ;; (cond ((empty-queue?)
+ ;; (set! front-ptr item)
+ ;; (set! rear-ptr item))
+ ;; (else
+ ;; (set-cdr! rear-ptr
+ ;; ...))))
blob - /dev/null
blob + a0a93c110bc90a6e78f9a918180abe2ef0370ce1 (mode 644)
--- /dev/null
+++ ex3-22-3.scm
+;; weiqun zhang's solution
+
+(define (make-queue)
+ (let ((front-ptr '())
+ (rear-ptr '()))
+ (define (prt-q)
+ (newline)
+ (display front-ptr))
+ (define (emp-q?)
+ (null? front-ptr))
+ (define (fro-q)
+ (if (emp-q?)
+ (error "FRONT called with an empty queue")
+ (car front-ptr)))
+ (define (ins-q! item)
+ (let ((new-pair (cons item '())))
+ (cond ((emp-q?)
+ (set! front-ptr new-pair)
+ (set! rear-ptr new-pair))
+ (else
+ (set-cdr! rear-ptr new-pair)
+ (set! rear-ptr new-pair)))))
+ (define (del-q!)
+ (cond ((emp-q?)
+ (error "DELETE! called with an empty queue"))
+ (else
+ (set! front-ptr (cdr front-ptr)))))
+ (define (dispach m)
+ (cond ((eq? m 'insert-queue!) ins-q!)
+ ((eq? m 'delete-queue!) (del-q!))
+ ((eq? m 'front-queue) (fro-q))
+ ((eq? m 'empty-queue?) (emp-q?))
+ ((eq? m 'print-queue) (prt-q))
+ (else (error "Undefined operation -- MAKE-QUEUE" m))))
+ dispatch))
+(define (insert-queue! queue item)
+ ((queue 'insert-queue!) item)
+ queue)
+(define (delete-queue! queue)
+ (queue 'delete-queue!)
+ queue)
+(define (empty-queue? queue)
+ (queue 'empty-queue?))
+(define (front-queue queue)
+ (queue 'front-queue))
+(define (print-queue queue)
+ (queue 'print-queue))
blob - /dev/null
blob + a62042b96ca71f046513c34afe8683648c72bca6 (mode 644)
--- /dev/null
+++ ex3-22-3.scm~
+;; weiqun zhang's solution
+
+(define (make-queue)
+ (let ((front-ptr '())
+ (rear-ptr '()))
+ (define (prt-q)
+ (newline)
+ (display front-ptr))
+ (define (emp-q?)
+ (null? front-ptr))
+ (define (fro-q)
+ (if (emp-q?)
+ (error "FRONT called with an empty queue")
+ (car front-ptr)))
+ (define (ins-q! item)
+ (let ((new-pair (cons item '())))
+ (cond ((emp-q?)
+ (set! front-ptr new-pair)
+ (set! rear-ptr new-pair))
+ (else
+ (set-cdr! rear-ptr new-pair)
+ (set! rear-ptr new-pair)))))
blob - /dev/null
blob + bcb7bd29581899eed3c9fa24f3bf416a52f755af (mode 644)
--- /dev/null
+++ ex3-22.scm
+;; Exercise 3.22. Instead of representing a queue as a pair of pointers, we can build a queue as a procedure with local state. The local state will consist of pointers to the beginning and the end of an ordinary list. Thus, the make-queue procedure will have the form
+
+(define (make-queue)
+ (let ((front-ptr '())
+ (rear-ptr '()))
+ (define (set-front-ptr! item)
+ (set! front-ptr item))
+ (define (set-rear-ptr! item)
+ (set! rear-ptr item))
+ (define (dispatch m)
+ (cond ((eq? m 'front-ptr) front-ptr)
+ ((eq? m 'rear-ptr) rear-ptr)
+ ((eq? m 'set-front-ptr!) set-front-ptr!)
+ ((eq? m 'set-rear-ptr!) set-rear-ptr!)))
+ dispatch))
+
+;; Complete the definition of make-queue andprovide implementations of the queue operations using this representation.
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; the four basic accessor/setter methods
+
+(define (front-ptr queue) (queue 'front-ptr))
+(define (rear-ptr queue) (queue 'rear-ptr))
+(define (set-front-ptr! queue item)
+ ((queue 'set-front-ptr!) item))
+(define (set-rear-ptr! queue item)
+ ((queue 'set-rear-ptr!) item))
+
+;; the rest remain untouched
+
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+;; Exercise 3.21
+
+;; Define a procedure print-queue that takes a queue as input and prints the sequence of items in the queue.
+
+(define (print-queue queue)
+ (newline)
+ (newline)
+ (display (front-ptr queue))
+ (newline)
+ (front-ptr queue))
+
+(define q (make-queue))
+(insert-queue! q 'a)
+(test-case (print-queue q) '(a))
+(insert-queue! q 'b)
+(test-case (print-queue q) '(a b))
+(insert-queue! q 'c)
+(test-case (print-queue q) '(a b c))
+(insert-queue! q 'd)
+(test-case (print-queue q) '(a b c d))
+(insert-queue! q 'e)
+(test-case (print-queue q) '(a b c d e))
+(delete-queue! q)
+(test-case (print-queue q) '(b c d e))
+(delete-queue! q)
+(test-case (print-queue q) '(c d e))
+
+
+ ;; (define (empty-queue?)
+ ;; (null? front-ptr))
+ ;; (define (set-front-ptr! item)
+ ;; (cond ((empty-queue?)
+ ;; (set! front-ptr item)
+ ;; (set! rear-ptr item))
+ ;; (else
+ ;; (set-cdr! rear-ptr
+ ;; ...))))
blob - /dev/null
blob + 3c0eae8b481f0353dcddd9759a87953a056b8570 (mode 644)
--- /dev/null
+++ ex3-22.scm~
+;; Exercise 3.22. Instead of representing a queue as a pair of pointers, we can build a queue as a procedure with local state. The local state will consist of pointers to the beginning and the end of an ordinary list. Thus, the make-queue procedure will have the form
+
+(define (make-queue)
+ (let ((front-ptr ...)
+ (rear-ptr ...))
+ <definitions of internal procedures>
+ (define (dispatch m) ...)
+ dispatch))
+
+;; Complete the definition of make-queue and provide implementations of the queue operations using this representation.
blob - /dev/null
blob + 94d72539add38e27416584db1a4fee02dc102cfe (mode 644)
--- /dev/null
+++ ex3-23-2.scm
+(define (front-ptr deque) (car deque))
+(define (rear-ptr deque) (cdr deque))
+(define (set-front-ptr! deque item) (set-car! deque item))
+(define (set-rear-ptr! deque item) (set-cdr! deque item))
+
+(define (make-deque) (cons '() '()))
+(define (empty-deque? deque)
+ (and (null? (front-ptr deque))
+ (null? (rear-ptr deque))))
+(define (print-deque deque)
+ (define (make-printable-list q)
+ (if (null? q)
+ '()
+ (cons (car q)
+ (make-printable-list (cddr q)))))
+ (newline)
+ (display (make-printable-list (front-ptr deque))))
+(define (rear-insert-deque! deque item)
+ (let ((new-pair (cons item (cons '() '()))))
+ (cond ((empty-deque? deque)
+ (set-front-ptr! deque new-pair)
+ (set-rear-ptr! deque new-pair))
+ (else
+ (set-car! (cdr new-pair) (rear-ptr deque))
+ (set-cdr! (cdr (rear-ptr deque)) new-pair)
+ (set-rear-ptr! deque new-pair)))))
+(define (front-insert-deque! deque item)
+ (let ((new-pair (cons item (cons '() '()))))
+ (cond ((empty-deque? deque)
+ (set-front-ptr! deque new-pair)
+ (set-rear-ptr! deque new-pair))
+ (else
+ (set-cdr! (cdr new-pair) (front-ptr deque))
+ (set-car! (cdr (front-ptr deque)) new-pair)
+ (set-front-ptr! deque new-pair)))))
+(define (front-deque deque)
+ (if (empty-deque? deque)
+ (error "FRONT called with an empty deque" deque)
+ (car (front-ptr deque))))
+(define (rear-deque deque)
+ (if (empty-deque? deque)
+ (error "REAR called with an empty deque" deque)
+ (car (rear-ptr deque))))
+(define (front-delete-deque! deque)
+ (cond ((empty-deque? deque)
+ (error "FRONT-DELETE! called with an empty deque" deque))
+ ((eq? (front-ptr deque) (rear-ptr deque))
+ (set-front-ptr! deque '())
+ (set-rear-ptr! deque '()))
+ (else
+ (set-front-ptr! deque (cddr (front-ptr deque)))
+ (set-car! (cdr (front-ptr deque)) '()))))
+(define (rear-delete-deque! deque)
+ (cond ((empty-deque? deque)
+ (error "REAR-DELETE! called with an empty deque" deque))
+ ((eq? (front-ptr deque) (rear-ptr deque))
+ (set-front-ptr! deque '())
+ (set-rear-ptr! deque '()))
+ (else
+ (set-rear-ptr! deque (cadr (rear-ptr deque)))
+ (set-cdr! (cdr (rear-ptr deque)) '()))))
+
+
blob - /dev/null
blob + 8bfb6469cac7cc075a23332696da3f31cf95ad9e (mode 644)
--- /dev/null
+++ ex3-23-2.scm~
+(define (front-ptr deque) (car deque))
blob - /dev/null
blob + d6cfe5137620322fe8412505f991cb66f0da463a (mode 644)
--- /dev/null
+++ ex3-23.lisp
+(defun make-deque ()
+ (cons '() '()))
+(defun front-ptr (deque)
+ (car deque))
+(defun rear-ptr (deque)
+ (cdr deque))
+(defun set-front-ptr! (deque item)
+ (setf (car deque) item))
+(defun set-rear-ptr! (deque item)
+ (setf (cdr deque) item))
+(defun empty-deque? (deque)
+ (null (front-ptr deque)))
+(defun front-deque (deque)
+ (if (empty-deque? deque)
+ (error "FRONT on empty deque")
+ (caar (front-ptr deque))))
+(defun rear-deque (deque)
+ (if (empty-deque? deque)
+ (error "REAR on empty deque")
+ (caar (rear-ptr deque))))
+(defun front-insert-deque! (deque item)
+ (let ((new-pair (cons (cons item '()) '())))
+ (cond ((empty-deque? deque)
+ (set-front-ptr! deque new-pair)
+ (set-rear-ptr! deque new-pair)
+ deque)
+ (t
+ (setf (cdr new-pair) (front-ptr deque))
+ (setf (cdar (front-ptr deque)) new-pair)
+ (set-front-ptr! deque new-pair)
+ deque))))
+(defun rear-insert-deque! (deque item)
+ (let ((new-pair (cons (cons item (rear-ptr deque)) '())))
+ (cond ((empty-deque? deque)
+ (set-front-ptr! deque new-pair)
+ (set-rear-ptr! deque new-pair)
+ deque)
+ (t
+ (setf (cdr (rear-ptr deque)) new-pair)
+ (set-rear-ptr! deque new-pair)
+ deque))))
+(defun front-delete-deque! (deque)
+ (cond ((empty-deque? deque)
+ (error "FRONT-DELETE on empty deque"))
+ (t
+ (set-front-ptr!
+ deque
+ (cdr (front-ptr deque)))
+ deque)))
+(defun rear-delete-deque! (deque)
+ (cond ((empty-deque? deque)
+ (error "REAR-DELETE on empty deque"))
+ (t
+ (set-rear-ptr! deque (cdar (rear-ptr deque)))
+ (setf (cdr (rear-ptr deque)) '())
+ deque)))
+(defun print-deque (deque)
+ (format t "(")
+ (mapcar (lambda (e)
+ (format t "~a " (car e)))
+ (front-ptr deque))
+ (format t ")"))
blob - /dev/null
blob + 187a7f5b53fb9b46ecb0aad4a99ea9c3fc055b01 (mode 644)
--- /dev/null
+++ ex3-23.lisp~
+(defun make-deque ()
+ (cons '() '()))
+(defun front-ptr (deque)
+ (car deque))
blob - /dev/null
blob + 339e2f145c5ab03189a8ee21f6434a536d597048 (mode 644)
--- /dev/null
+++ ex3-23.scm
+;; Exercise 3.23. A deque (``double-ended queue'') is a sequence in which items can be inserted and deleted at either the front or the rear. Operations on deques are the constructor make-deque, the predicate empty-deque?, selectors front-deque and rear-deque, and mutators front-insert-deque!, rear-insert-deque!, front-delete-deque!, and rear-delete-deque!. Show how to represent deques using pairs, and give implementations of the operations.23 All operations should be accomplished in (1) steps.
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-link val prev next)
+ (cons (cons val prev) next))
+(define (link-value l)
+ (caar l))
+(define (link-prev l)
+ (cdar l))
+(define (link-next l)
+ (cdr l))
+(define (set-link-prev! link prev)
+ (set-cdr! (car link) prev))
+(define (set-link-next! link next)
+ (set-cdr! link next))
+(define (link->list l)
+ (map car l))
+
+(define (make-deque)
+ (cons '() '()))
+(define (empty-deque? deque)
+ (null? (car deque)))
+(define (front-deque deque)
+ (link-value (car deque)))
+(define (rear-deque deque)
+ (link-value (cdr deque)))
+(define (front-insert-deque! deque item)
+ (let ((new-link (make-link item '() (car deque))))
+ (cond ((empty-deque? deque)
+ (set-car! deque new-link)
+ (set-cdr! deque new-link))
+ (else
+ (set-link-prev! (car deque) new-link)
+ (set-car! deque new-link))))
+ deque)
+(define (rear-insert-deque! deque item)
+ (let ((new-link (make-link item (cdr deque) '())))
+ (cond ((empty-deque? deque)
+ (set-car! deque new-link)
+ (set-cdr! deque new-link))
+ (else
+ (set-link-next! (cdr deque) new-link)
+ (set-cdr! deque new-link))))
+ deque)
+
+(define (front-delete-deque! deque)
+ (if (empty-deque? deque)
+ (error "FRONT-DELETE-DEQUE! on empty deque"))
+ (set-car! deque (link-next (car deque)))
+ (if (null? (car deque))
+ (set-cdr! deque '())
+ (set-link-prev! (car deque) '())))
+(define (rear-delete-deque! deque)
+ (if (empty-deque? deque)
+ (error "REAR-DELETE-DEQUE! on empty deque"))
+ (set-cdr! deque (link-prev (cdr deque)))
+ (if (null? (cdr deque))
+ (set-car! deque '())
+ (set-link-next! (cdr deque) '())))
+(define (deque->list deque)
+ (link->list (car deque)))
+
+(define (print-deque deque)
+ (newline)
+ (newline)
+ (display (deque->list deque))
+ (newline)
+ (deque->list deque))
+
+(define la (make-link 'a '() '()))
+(define lb (make-link 'b '() '()))
+(define lc (make-link 'c '() '()))
+(define ld (make-link 'd '() '()))
+(set-link-next! la lb)
+(set-link-prev! lb la)
+(set-link-next! lb lc)
+(set-link-prev! lc lb)
+(set-link-next! lc ld)
+(set-link-prev! ld lc)
+(test-case (link->list la) '(a b c d))
+
+(define dq (make-deque))
+(front-insert-deque! dq 'a)
+(test-case (print-deque dq) '(a))
+(front-insert-deque! dq 'b)
+(test-case (print-deque dq) '(b a))
+(rear-insert-deque! dq 'c)
+(test-case (print-deque dq) '(b a c))
+(rear-insert-deque! dq 'd)
+(test-case (print-deque dq) '(b a c d))
+(front-delete-deque! dq)
+(test-case (print-deque dq) '(a c d))
+(rear-delete-deque! dq)
+(test-case (print-deque dq) '(a c))
+(test-case (front-deque dq) 'a)
+(test-case (rear-deque dq) 'c)
blob - /dev/null
blob + c327866c4a10ac8fce812cc24f57d286608f770b (mode 644)
--- /dev/null
+++ ex3-23.scm~
+;; Exercise 3.23. A deque (``double-ended queue'') is a sequence in which items can be inserted and deleted at either the front or the rear. Operations on deques are the constructor make-deque, the predicate empty-deque?, selectors front-deque and rear-deque, and mutators front-insert-deque!, rear-insert-deque!, front-delete-deque!, and rear-delete-deque!. Show how to represent deques using pairs, and give implementations of the operations.23 All operations should be accomplished in (1) steps.
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-link val prev next)
+ (cons (cons val prev) next))
+(define (link-value)
+ (caar l))
+(define (link-prev l)
+ (cdar l))
+(define (link-next l)
+ (cdr l))
+(define (set-link-prev! link prev)
+ (set-cdr! (car link) prev))
+(define (set-link-next! link next)
+ (set-cdr! link next))
+(define (link->list l)
+ (map car l))
+
+(define (make-deque)
+ (cons '() '()))
+(define (empty-deque? deque)
+ (null? (car deque)))
+(define (front-deque deque)
+ (link-value (car deque)))
+(define (rear-deque deque)
+ (link-value (cdr deque)))
+(define (front-insert-deque! deque item)
+ (let ((new-link (make-link item '() (car deque))))
+ (cond ((empty-deque? deque)
+ (set-car! deque new-link)
+ (set-cdr! deque new-link))
+ (else
+ (set-link-prev! (car deque) new-link)
+ (set-car! deque new-link))))
+ deque)
+(define (rear-insert-deque! deque item)
+ (let ((new-link (make-link item (cdr deque) '())))
+ (cond ((empty-deque? deque)
+ (set-car! deque new-link)
+ (set-cdr! deque new-link))
+ (else
+ (set-link-next! (cdr deque) new-link)
+ (set-cdr! deque new-link))))
+ deque)
+(define (front-delete-deque! deque)
+ (set-car! deque (link-next (car deque)))
+ (if (null? (car deque))
+ (set-cdr! deque '())
+ (set-link-prev! (car deque) '())))
+(define (rear-delete-deque! deque)
+ (set-cdr! deque (link-prev (cdr deque)))
+ (if (null? (cdr deque))
+ (set-car! deque '())
+ (set-link-next! (cdr deque) '())))
+(define (deque->list deque)
+ (link->list (car deque)))
+
+(define (print-deque deque)
+ (newline)
+ (newline)
+ (display (deque->list deque))
+ (newline)
+ deque)
+
+(define la (make-link 'a '() '()))
+(define lb (make-link 'b '() '()))
+(define lc (make-link 'c '() '()))
+(define ld (make-link 'd '() '()))
+(set-link-next! la lb)
+(set-link-prev! lb la)
+(set-link-next! lb lc)
+(set-link-prev! lc lb)
+(set-link-next! lc ld)
+(set-link-prev! ld lc)
+(test-case (link->list la) '(a b c d))
+
+(define dq (make-deque))
+(front-insert-deque! dq 'a)
+(test-case (print-deque dq) '(a))
+(front-insert-deque! dq 'b)
+(test-case (print-deque dq) '(b a))
+(rear-insert-deque! dq 'c)
+(test-case (print-deque dq) '(b a c))
+(rear-insert-deque! dq 'd)
+(test-case (print-deque dq) '(b a c d))
+(front-delete-deque! dq)
+(test-case (print-deque dq) '(a c d))
+(rear-delete-deque! dq)
+(test-case (print-deque dq) '(a c))
+(test-case (front-deque dq) 'a)
+(test-case (rear-deque dq) 'c)
blob - /dev/null
blob + 95140f0214f925a2b8dff180fcc11ca2ae7845a8 (mode 644)
--- /dev/null
+++ ex3-24.scm
+;; Exercise 3.24. In the table implementations above, the keys are tested for equality using equal? (called by assoc). This is not always the appropriate test. For instance, we might have a table with numeric keys in which we don't need an exact match to the number we're looking up, but only a number within some tolerance of it. Design a table constructor make-table that takes as an argument a same-key? procedure that will be used to test ``equality'' of keys. Make-table should return a dispatch procedure that can be used to access appropriate lookup and insert! procedures for a local table.
+
+(define (make-table same-key?)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((same-key? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table (lambda (x y) (< (abs (- x y)) 0.1))))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(put 4 3 '4x3=12)
+(test-case (get 4.01 2.99) '4x3=12)
+(test-case (get 4 3) '4x3=12)
+(put 4.01 2.99 '4.01x2.99=11.9899)
+(test-case (get 4.01 2.99) '4.01x2.99=11.9899)
+(test-case (get 4 3) '4.01x2.99=11.9899)
+(test-case (get 4.11 3.0) false)
+(put 8.06 2.06 '8.06x2.06=16.6036)
+(put 7.94 1.94 '7.94x1.94=15.4036)
+
+; note that most recent definition is pulled first, regardless of which is closer
+(test-case (get 8 2) '7.94x1.94=15.4036)
+(test-case (get 8.039 2.039) '7.94x1.94=15.4036)
+(test-case (get 8.041 2.041) '8.06x2.06=16.6036)
+(test-case (get 8.159 2.159) '8.06x2.06=16.6036)
+(test-case (get 7.85 1.85) '7.94x1.94=15.4036)
+
+
blob - /dev/null
blob + ae4079ebf4ac87cc7c31dde1cc9272ed06e7ea15 (mode 644)
--- /dev/null
+++ ex3-24.scm~
+(define (lookup key table)
+ (let ((record (assoc key (cdr table))))
+ (if record
+ (cdr record)
+ false)))
+(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+(define (insert! key value table)
+ (let ((record (assoc key (cdr table))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! table
+ (cons (cons key value) (cdr table)))))
+ 'ok)
+(define (make-table)
+ (list '*table*))
+
+(define (lookup key-1 key-2 table)
+ (let ((subtable (assoc key-1 (cdr table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+(define (insert! key-1 key-2 value table)
+ (let ((subtable (assoc key-1 (cdr table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! table
+ (cons (list key-1 (cons key-2 value))
+ (cdr table)))))
+ 'ok)
+
+
+;; didn't finish
+
+(define (make-table)
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+ Exercise 3.24. In the table implementations above, the keys are tested for equality using equal? (called by assoc). This is not always the appropriate test. For instance, we might have a table with numeric keys in which we don't need an exact match to the number we're looking up, but only a number within some tolerance of it. Design a table constructor make-table that takes as an argument a same-key? procedure that will be used to test ``equality'' of keys. Make-table should return a dispatch procedure that can be used to access appropriate lookup and insert! procedures for a local table.
blob - /dev/null
blob + fdb0bc89a0669179881c5292302a014bf95cef34 (mode 644)
--- /dev/null
+++ ex3-25-2.scm
+;; Exercise 3.25. Generalizing one- and two-dimensional tables, show how to implement a table in which values are stored under an arbitrary number of keys and different values may be stored under different numbers of keys. The lookup and insert! procedures should take as input a list of keys used to access the table.
+
+;; we could actually keep the procedure as-is, by treating the list of keys as a single key and comparing equality of lists. The downside to this is that there would be no organization based on keys.
+
+(define (make-table) (list '*table*))
+
+(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+
+(define (lookup keys table)
+ (if (null? keys)
+ (error "no keys passed to lookup")
+ (cond
+ ;; table is the record
+ ((null? (cdr keys)) (cdr table))
+ (((cdr table)
+
+ (lookup (cdr keys)
+ ((
+;; the problem here is that the user could actually insert, for his value, a list structure that resembled a subtable. This would trick our lookup procedure into thinking that there is no value for this specific key.
+
+;; for example, suppose someone tried to insert
+
+(insert! '(usa new-york) (list (cons new-york 1)) tbl)
+;; this would shadow the previous entry by appearing earlier in the table
+;; I think this implementation is really insecure
+
+ (let ((subtable (assoc (car keys) (cdr table))))
+ (if subtable
+
+ ...
+ (lookup (cdr keys) subtable))
+ false)))
+
+ ((null? (cdr keys))
+ (if (
+
+;;too many keys
+
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define tbl (make-table))
+;; 2nd number refers to population in millions
+(insert! '(usa california los-angeles) 3.88 tbl)
+(insert! '(usa new-york new-york) 8.41 tbl)
+(insert! '(china beijing) 21.15 tbl)
+(insert! '(china shanghai) 24.15 tbl)
+(insert! '(pakistan karachi) 23.5 tbl)
+(insert! '(hong-kong) 7.22 tbl)
+(insert! '(singapore) 5.4 tbl)
+(test-case (lookup '(usa california los-angeles) tbl) 3.88)
+(test-case (lookup '(china shanghai) tbl) 24.15)
+(test-case (lookup '(singapore) tbl) 5.4)
+(test-case (lookup '(usa california rowland-heights) tbl) #f)
+(test-case (lookup '(usa new-york) tbl) #f)
+(test-case (lookup '(usa new-york new-york) tbl) 8.41)
+(test-case (lookup '(usa new-york new-york new-york) tbl) #f)
+
+
+
+
+
blob - /dev/null
blob + ad43880db24f9bfebfa540824fae42a01ce5516d (mode 644)
--- /dev/null
+++ ex3-25-2.scm~
+;; Exercise 3.25. Generalizing one- and two-dimensional tables, show how to implement a table in which values are stored under an arbitrary number of keys and different values may be stored under different numbers of keys. The lookup and insert! procedures should take as input a list of keys used to access the table.
+
+;; we could actually keep the procedure as-is, by treating the list of keys as a single key and comparing equality of lists. The downside to this is that there would be no organization based on keys.
+
+(define (make-table) (list '*table*))
+
+(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+
+(define (lookup keys table)
+ (if (null? keys)
+ (error "no keys passed to lookup")
+ (let ((subtable (assoc (car keys) (cdr table))))
+ (if subtable
+ (if (null? (cdr keys))
+ ...
+ (lookup (cdr keys) subtable))
+ false)))
+
+ ((null? (cdr keys))
+ (if (
+
+;;too many keys
+
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define tbl (make-table))
+;; 2nd number refers to population in millions
+(insert! '(usa california los-angeles) 3.88 tbl)
+(insert! '(usa new-york new-york) 8.41 tbl)
+(insert! '(china beijing) 21.15 tbl)
+(insert! '(china shanghai) 24.15 tbl)
+(insert! '(pakistan karachi) 23.5 tbl)
+(insert! '(hong-kong) 7.22 tbl)
+(insert! '(singapore) 5.4 tbl)
+(test-case (lookup '(usa california los-angeles) tbl) 3.88)
+(test-case (lookup '(china shanghai) tbl) 24.15)
+(test-case (lookup '(singapore) tbl) 5.4)
+(test-case (lookup '(usa california rowland-heights) tbl) #f)
+(test-case (lookup '(usa new-york) tbl) #f)
+(test-case (lookup '(usa new-york new-york) tbl) 8.41)
+(test-case (lookup '(usa new-york new-york new-york) tbl) #f)
+
+
+
+
+
blob - /dev/null
blob + bf53002906bb3275016839881e3d3a01fe1c77eb (mode 644)
--- /dev/null
+++ ex3-25-3.scm
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-list)
+ (define (lookup1 keys table)
+ (let ((subtable (assoc (car keys) (cdr table))))
+ (if subtable
+ (if (null? (cdr keys))
+ (cdr subtable)
+ (lookup1 (cdr keys) subtable))
+ false)))
+ (lookup1 key-list local-table))
+ (define (insert! key-list value)
+ (define (make-entry keys)
+ (if (null? (cdr keys))
+ (cons (car keys) value)
+ (list (car keys) (make-entry (cdr keys)))))
+ (define (insert1 keys table)
+ (let ((subtable (assoc (car keys) (cdr table))))
+ (if subtable
+ (if (null? (cdr keys))
+ (set-cdr! subtable value)
+ (insert1 (cdr keys) subtable))
+ (set-cdr! table (cons (make-entry keys)
+ (cdr table))))))
+ (insert1 key-list local-table)
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m)))
+ dispatch))
blob - /dev/null
blob + 413a989558d650cd4c55e16b8453432700ef9dd0 (mode 644)
--- /dev/null
+++ ex3-25-3.scm~
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-list)
+ (define (lookup1 keys table)
+ (let ((subtable (assoc (car keys) (cdr table))))
+ (if subtable
+ (if (null? (cdr keys))
+ (cdr subtable)
+ (lookup1 (cdr keys) subtable))
+ false)))
+ (lookup1 key-list local-table))
blob - /dev/null
blob + b29d583e7fae9736d0de5ef713835c8f86d15162 (mode 644)
--- /dev/null
+++ ex3-25.scm
+;; Exercise 3.25. Generalizing one- and two-dimensional tables, show how to implement a table in which values are stored under an arbitrary number of keys and different values may be stored under different numbers of keys. The lookup and insert! procedures should take as input a list of keys used to access the table.
+
+;; we could actually keep the procedure as-is, by treating the list of keys as a single key and comparing equality of lists. The downside to this is that there would be no organization based on keys.
+
+(define (lookup key table)
+ (let ((record (assoc key (cdr table))))
+ (if record
+ (cdr record)
+ false)))
+(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+
+(define (insert! key value table)
+ (let ((record (assoc key (cdr table))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! table
+ (cons (cons key value) (cdr table)))))
+ 'ok)
+
+(define (make-table)
+ (list '*table*))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define tbl (make-table))
+;; 2nd number refers to population in millions
+(insert! '(usa california los-angeles) 3.88 tbl)
+(insert! '(usa new-york new-york) 8.41 tbl)
+(insert! '(china beijing) 21.15 tbl)
+(insert! '(china shanghai) 24.15 tbl)
+(insert! '(pakistan karachi) 23.5 tbl)
+(insert! '(hong-kong) 7.22 tbl)
+(insert! '(singapore) 5.4 tbl)
+(test-case (lookup '(usa california los-angeles) tbl) 3.88)
+(test-case (lookup '(china shanghai) tbl) 24.15)
+(test-case (lookup '(singapore) tbl) 5.4)
+(test-case (lookup '(usa california rowland-heights) tbl) #f)
+(test-case (lookup '(usa new-york) tbl) #f)
+(test-case (lookup '(usa new-york new-york) tbl) 8.41)
+(test-case (lookup '(usa new-york new-york new-york) tbl) #f)
+
+
+
+
+
blob - /dev/null
blob + ad43880db24f9bfebfa540824fae42a01ce5516d (mode 644)
--- /dev/null
+++ ex3-25.scm~
+;; Exercise 3.25. Generalizing one- and two-dimensional tables, show how to implement a table in which values are stored under an arbitrary number of keys and different values may be stored under different numbers of keys. The lookup and insert! procedures should take as input a list of keys used to access the table.
+
+;; we could actually keep the procedure as-is, by treating the list of keys as a single key and comparing equality of lists. The downside to this is that there would be no organization based on keys.
+
+(define (make-table) (list '*table*))
+
+(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+
+(define (lookup keys table)
+ (if (null? keys)
+ (error "no keys passed to lookup")
+ (let ((subtable (assoc (car keys) (cdr table))))
+ (if subtable
+ (if (null? (cdr keys))
+ ...
+ (lookup (cdr keys) subtable))
+ false)))
+
+ ((null? (cdr keys))
+ (if (
+
+;;too many keys
+
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define tbl (make-table))
+;; 2nd number refers to population in millions
+(insert! '(usa california los-angeles) 3.88 tbl)
+(insert! '(usa new-york new-york) 8.41 tbl)
+(insert! '(china beijing) 21.15 tbl)
+(insert! '(china shanghai) 24.15 tbl)
+(insert! '(pakistan karachi) 23.5 tbl)
+(insert! '(hong-kong) 7.22 tbl)
+(insert! '(singapore) 5.4 tbl)
+(test-case (lookup '(usa california los-angeles) tbl) 3.88)
+(test-case (lookup '(china shanghai) tbl) 24.15)
+(test-case (lookup '(singapore) tbl) 5.4)
+(test-case (lookup '(usa california rowland-heights) tbl) #f)
+(test-case (lookup '(usa new-york) tbl) #f)
+(test-case (lookup '(usa new-york new-york) tbl) 8.41)
+(test-case (lookup '(usa new-york new-york new-york) tbl) #f)
+
+
+
+
+
blob - /dev/null
blob + 53c0721dccff8c6ffc8519acab4177aeb0411215 (mode 644)
--- /dev/null
+++ ex3-26-2.scm
+;; Exercise 3.26. To search a table as implemented above, one needs to scan through the list of records. This is basically the unordered list representation of section 2.3.3. For large tables, it may be more efficient to structure the table in a different manner. Describe a table implementation where the (key, value) records are organized using a binary tree, assuming that keys can be ordered in some way (e.g., numerically or alphabetically). (Compare exercise 2.66 of chapter 2.)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-tree key value)
+ (list key value '() '()))
+(define (tree-key tree)
+ (car tree))
+(define (tree-value tree)
+ (cadr tree))
+(define (left-branch tree)
+ (caddr tree))
+(define (right-branch tree)
+ (cadddr tree))
+(define (set-tree-value! tree value)
+ (set-car! (cdr tree) value))
+(define (insert-left-branch! tree key value)
+ (set-car! (cddr tree)
+ (make-tree key value)))
+(define (insert-right-branch! tree key value)
+ (set-car! (cdddr tree)
+ (make-tree key value)))
+
+;; (define family-tree (make-tree 'me 'aaron))
+;; (insert-left-branch! family-tree 'mom 'amy)
+;; (insert-right-branch! family-tree 'dad 'james)
+;; (insert-left-branch! (left-branch family-tree) 'grandma '?)
+;; (insert-right-branch! (left-branch family-tree) 'grandpa 'sean)
+;; (insert-left-branch! (right-branch family-tree) 'grandma '??)
+;; (insert-right-branch! (right-branch family-tree) 'grandpa 'yuandu)
+;; (test-case (tree-value (right-branch (left-branch family-tree))) 'sean)
+;; (test-case (tree-key (left-branch (right-branch family-tree))) 'grandma)
+;; (test-case (tree-value (right-branch family-tree)) 'james)
+;; (set-tree-value! (right-branch family-tree) 'chen-min)
+;; (test-case (tree-value (right-branch family-tree)) 'chen-min)
+
+(define (make-table less-thanp)
+ (let ((local-table '()))
+ (define (assoc key tree)
+ (cond ((null? tree) false)
+ ((less-thanp key (tree-key tree)) (assoc key (left-branch tree)))
+ ((less-thanp (tree-key tree) key) (assoc key (right-branch tree)))
+ (else tree))) ;equality
+ (define (lookup key)
+ (let ((match (assoc key local-table)))
+ (if match
+ (tree-value match)
+ false)))
+ (define (insert! key value)
+ (define (insert-tree! tree)
+ (cond ((less-thanp key (tree-key tree))
+ (if (null? (left-branch tree))
+ (insert-left-branch! tree key value)
+ (insert-tree! (left-branch tree))))
+ ((less-thanp (tree-key tree) key)
+ (if (null? (right-branch tree))
+ (insert-right-branch! tree key value)
+ (insert-tree! (right-branch tree))))
+ (else (set-tree-value! tree value)))) ;; equality
+ (if (null? local-table)
+ (set! local-table (make-tree key value))
+ (insert-tree! local-table)))
+ (define (dispatch m)
+ (cond ((eq? m 'lookup) lookup)
+ ((eq? m 'insert!) insert!)
+ ((eq? m 'debug-print) local-table)
+ (else (error "Unknown request -- MAKE-TABLE" m))))
+ dispatch))
+
+(define (insert! key value table)
+ ((table 'insert!) key value))
+(define (lookup key table)
+ ((table 'lookup) key))
+
+(define israel-sons (make-table <))
+(insert! 3 'levi israel-sons)
+(insert! 5 'dan israel-sons)
+(test-case (lookup 3 israel-sons) 'levi)
+(test-case (lookup 5 israel-sons) 'dan)
+(test-case (lookup 12 israel-sons) false)
+(test-case (lookup 11 israel-sons) false)
+(test-case (lookup 1 israel-sons) false)
+(insert! 12 'benjamin israel-sons)
+(insert! 11 'joseph israel-sons)
+(insert! 1 'reuben israel-sons)
+(test-case (lookup 12 israel-sons) 'benjamin)
+(test-case (lookup 11 israel-sons) 'joseph)
+(test-case (lookup 1 israel-sons) 'reuben)
+(insert! 2 'simeon israel-sons)
+(test-case (lookup 3 israel-sons) 'levi)
+(insert! 8 'asher israel-sons)
+(insert! 7 'gad israel-sons)
+(insert! 6 'naphtali israel-sons)
+(insert! 9 'issachar israel-sons)
+(insert! 10 'zebulun israel-sons)
+(insert! 4 'judah israel-sons)
+(test-case (lookup 4 israel-sons) 'judah)
+(test-case (lookup 8 israel-sons) 'asher)
+(test-case (lookup 13 israel-sons) false)
+(insert! 12 'manasseh israel-sons)
+(insert! 13 'ephraim israel-sons)
+(insert! 11 'benjamin israel-sons)
+(test-case (lookup 12 israel-sons) 'manasseh)
+(test-case (lookup 13 israel-sons) 'ephraim)
+(test-case (israel-sons 'debug-print)
+ '(3 levi (1 reuben () (2 simeon () ())) (5 dan (4 judah () ()) (12 manasseh (11 benjamin (8 asher (7 gad (6 naphtali () ()) ()) (9 issachar () (10 zebulun () ()))) ()) (13 ephraim () ())))))
+
+(define by-mother (make-table string<?))
+(insert! "leah" 'reuben by-mother)
+(test-case (lookup "leah" by-mother) 'reuben)
+(insert! "leah" 'simeon by-mother)
+(test-case (lookup "leah" by-mother) 'simeon)
+(insert! "zilpah" 'gad by-mother)
+(insert! "bilhah" 'dan by-mother)
+(insert! "rachel" 'joseph by-mother)
+(test-case (lookup "zilpah" by-mother) 'gad)
+(test-case (lookup "bilhah" by-mother) 'dan)
+(test-case (lookup "rachel" by-mother) 'joseph)
+
blob - /dev/null
blob + 7a4e07cab7d15c4e13f26471f364c708bc9bd4de (mode 644)
--- /dev/null
+++ ex3-26-2.scm~
+;; Exercise 3.26. To search a table as implemented above, one needs to scan through the list of records. This is basically the unordered list representation of section 2.3.3. For large tables, it may be more efficient to structure the table in a different manner. Describe a table implementation where the (key, value) records are organized using a binary tree, assuming that keys can be ordered in some way (e.g., numerically or alphabetically). (Compare exercise 2.66 of chapter 2.)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-tree key value)
+ (list key value '() '()))
+(define (tree-key tree)
+ (car tree))
+(define (tree-value tree)
+ (cadr tree))
+(define (left-branch tree)
+ (caddr tree))
+(define (right-branch tree)
+ (cadddr tree))
+(define (set-tree-value! tree value)
+ (set-car! (cdr tree) value))
+(define (insert-left-branch! tree key value)
+ (set-car! (cddr tree)
+ (make-tree key value)))
+(define (insert-right-branch! tree key value)
+ (set-car! (cdddr tree)
+ (make-tree key value)))
+
+;; (define family-tree (make-tree 'me 'aaron))
+;; (insert-left-branch! family-tree 'mom 'amy)
+;; (insert-right-branch! family-tree 'dad 'james)
+;; (insert-left-branch! (left-branch family-tree) 'grandma '?)
+;; (insert-right-branch! (left-branch family-tree) 'grandpa 'sean)
+;; (insert-left-branch! (right-branch family-tree) 'grandma '??)
+;; (insert-right-branch! (right-branch family-tree) 'grandpa 'yuandu)
+;; (test-case (tree-value (right-branch (left-branch family-tree))) 'sean)
+;; (test-case (tree-key (left-branch (right-branch family-tree))) 'grandma)
+;; (test-case (tree-value (right-branch family-tree)) 'james)
+;; (set-tree-value! (right-branch family-tree) 'chen-min)
+;; (test-case (tree-value (right-branch family-tree)) 'chen-min)
+
+(define (make-table less-thanp)
+ (let ((local-table '()))
+ (define (assoc key tree)
+ (cond ((null? tree) false)
+ ((less-thanp key (tree-key tree)) (assoc key (left-branch tree)))
+ ((less-thanp (tree-key tree) key) (assoc key (right-branch tree)))
+ (else tree))) ;equality
+ (define (lookup key)
+ (let ((match (assoc key local-table)))
+ (if match
+ (tree-value match)
+ false)))
+ (define (insert! key value)
+ (define (insert-tree! tree)
+ (if (equalp key (tree-key tree))
+ (set-tree-value! tree value)
+ (if (less-thanp key (tree-key tree))
+ (if (null? (left-branch tree))
+ (insert-left-branch! tree key value)
+ (insert-tree! (left-branch tree)))
+ (if (null? (right-branch tree))
+ (insert-right-branch! tree key value)
+ (insert-tree! (right-branch tree))))))
+ (if (null? local-table)
+ (set! local-table (make-tree key value))
+ (insert-tree! local-table)))
+ (define (dispatch m)
+ (cond ((eq? m 'lookup) lookup)
+ ((eq? m 'insert!) insert!)
+ ((eq? m 'debug-print) local-table)
+ (else (error "Unknown request -- MAKE-TABLE" m))))
+ dispatch))
+
+(define (insert! key value table)
+ ((table 'insert!) key value))
+(define (lookup key table)
+ ((table 'lookup) key))
+
+(define israel-sons (make-table = <))
+(insert! 3 'levi israel-sons)
+(insert! 5 'dan israel-sons)
+(test-case (lookup 3 israel-sons) 'levi)
+(test-case (lookup 5 israel-sons) 'dan)
+(test-case (lookup 12 israel-sons) false)
+(test-case (lookup 11 israel-sons) false)
+(test-case (lookup 1 israel-sons) false)
+(insert! 12 'benjamin israel-sons)
+(insert! 11 'joseph israel-sons)
+(insert! 1 'reuben israel-sons)
+(test-case (lookup 12 israel-sons) 'benjamin)
+(test-case (lookup 11 israel-sons) 'joseph)
+(test-case (lookup 1 israel-sons) 'reuben)
+(insert! 2 'simeon israel-sons)
+(test-case (lookup 3 israel-sons) 'levi)
+(insert! 8 'asher israel-sons)
+(insert! 7 'gad israel-sons)
+(insert! 6 'naphtali israel-sons)
+(insert! 9 'issachar israel-sons)
+(insert! 10 'zebulun israel-sons)
+(insert! 4 'judah israel-sons)
+(test-case (lookup 4 israel-sons) 'judah)
+(test-case (lookup 8 israel-sons) 'asher)
+(test-case (lookup 13 israel-sons) false)
+(insert! 12 'manasseh israel-sons)
+(insert! 13 'ephraim israel-sons)
+(insert! 11 'benjamin israel-sons)
+(test-case (lookup 12 israel-sons) 'manasseh)
+(test-case (lookup 13 israel-sons) 'ephraim)
+(test-case (israel-sons 'debug-print)
+ '(3 levi (1 reuben () (2 simeon () ())) (5 dan (4 judah () ()) (12 manasseh (11 benjamin (8 asher (7 gad (6 naphtali () ()) ()) (9 issachar () (10 zebulun () ()))) ()) (13 ephraim () ())))))
+
+(define by-mother (make-table string=? string<?))
+(insert! "leah" 'reuben by-mother)
+(test-case (lookup "leah" by-mother) 'reuben)
+(insert! "leah" 'simeon by-mother)
+(test-case (lookup "leah" by-mother) 'simeon)
+(insert! "zilpah" 'gad by-mother)
+(insert! "bilhah" 'dan by-mother)
+(insert! "rachel" 'joseph by-mother)
+(test-case (lookup "zilpah" by-mother) 'gad)
+(test-case (lookup "bilhah" by-mother) 'dan)
+(test-case (lookup "rachel" by-mother) 'joseph)
+
blob - /dev/null
blob + 5b8a906165eb9455147efcb5339fb9180a0c590e (mode 644)
--- /dev/null
+++ ex3-26-3.scm
+(define (make-table)
+ (define local-table '())
+ (define make-record cons)
+ (define key-record car)
+ (define value-record cdr)
+ (define (make-tree entry left right)
+ (list entry let right))
+ (define entry car)
+ (define left-branch cadr)
+ (define right-branch caddr)
+ (define key=? equal?)
+ (define (list<? l1 l2)
+ (andmap key<? l1 l2))
+ (define (key<? key1 key2)
+ (cond ((and (string? key1)
+ (string? key2)) (string<? key1 key2))
+ ((and (number? key1)
+ (number? key2)) (< key1 key2))
+ ((and (char? key1)
+ (char? key2)) (char<? key1 key2))
+ (else (error "Unsupported key types -- KEY<?" key1 key2))))
+ (define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((key=? (key-record x) (key-record (entry set))) true)
+ ((key<? (key-record x) (key-record (entry set)))
+ (element-of-set? x (left-branch set)))
+ (else
+ (element-of-set? x (right-branch set)))))
+ (define (adjoin-set x set)
+ (cond ((null? set) (make-tree x '() '()))
+ ((key=? (key-record x) (key-record (entry set))) set)
+ ((key<? (key-record x) (key-record (entry set)))
+ (make-tree (entry set)
+ (adjoin-set x (left-branch set))
+ (right-branch set)))
+ (else
+ (make-tree (entry set)
+ (left-branch set)
+ (adjoin-set x (right-branch set))))))
+ (define (lookup key records)
+ (if (null? records)
+ false
+ (let* ((record (entry records))
+ (key-entry (key-record record)))
+ (cond ((key=? key key-entry) (value-record record))
+ ((key<? key key-entry) (lookup key (left-branch records)))
+ (else (lookup key (right-branch records)))))))
+ (define (insert! key value)
+ (set! local-table
+ (adjoin-set (cons key value)
+ local-table)))
+ (define (dispatch m)
+ (cond ((eq? m 'lookup)
+ (lambda (key)
+ (lookup key local-table)))
+ ((eq? m 'insert!) insert!)
+ ((eq? m 'print) local-table)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch)
+
blob - /dev/null
blob + 435895d63197163acfd208f882efc2d889416465 (mode 644)
--- /dev/null
+++ ex3-26-3.scm~
+(define (make-table)
+ (define local-table '())
+ (define make-record cons)
+ (define key-record car)
+ (define value-record cdr)
+ (define (make-tree entry left right)
+ (list entry let right))
+ (define entry car)
+ (define left-branch cadr)
+ (define right-branch caddr)
+ (define key=? equal?)
+ (define (list<? l1 l2)
+ (andmap key<? l1 l2))
+ (define (key<? key1 key2)
+ (cond ((and (string? key1)
+ (string? key2)) (string<? key1 key2))
+ ((and (number? key1)
+ (number? key2)) (< key1 key2))
+ ((and (char? key1)
+ (char? key2)) (char<? key1 key2))
+ (else (error "Unsupported key types -- KEY<?" key1 key2))))
+ (define (element-of-set? x set)
+ (cond ((null? set) false)
+ ((key=? (key-record x) (key-record (entry set))) true)
+ ((key<? (key-record x) (key-record (entry set)))
+ (element-of-set? x (left-branch set)))
+ (else
+ (element-of-set? x (right-branch set)))))
+
blob - /dev/null
blob + c13cac97f3bacdf6806e65749316784291908256 (mode 644)
--- /dev/null
+++ ex3-26.lisp
+(defun make-tree (entry left right)
+ (list entry left right))
+(defun make-leaf (entry)
+ (list entry nil nil))
+(defun entry (tree)
+ (car tree))
+(defun set-entry! (tree ent)
+ (setf (car tree) ent))
+(defun left-branch (tree)
+ (cadr tree))
+(defun set-left-branch! (tree lb)
+ (setf (cadr tree) lb))
+(defun right-branch (tree)
+ (caddr tree))
+(defun set-right-branch! (tree rb)
+ (setf (caddr tree) rb))
+(defun make-record (key data)
+ (list key data))
+(defun key (record)
+ (car record))
+(defun data (record)
+ (cadr record))
+
+(defun make-table (&key (<? #'<))
+ (let ((local-table (cons '*head* nil)))
+ (labels ((tree-root ()
+ (cdr local-table))
+ (set-tree-root! (node)
+ (setf (cdr local-table) node))
+ (node-lookup (key node)
+ (if (null node)
+ nil
+ (let* ((cur-entry (entry node))
+ (cur-key (key cur-entry)))
+ (cond ((funcall <? key cur-key)
+ (node-lookup
+ key
+ (left-branch node)))
+ ((funcall <? cur-key key)
+ (node-lookup
+ key
+ (right-branch node)))
+ (t ; equal
+ cur-entry)))))
+ (lookup (key)
+ (node-lookup key (cdr local-table)))
+ (node-insert (key data node)
+ (let* ((cur-entry (entry node))
+ (cur-key (key cur-entry)))
+ (cond ((funcall <? key cur-key)
+ (if if (null (left-branch node))
+ (set-left-branch!
+ node
+ (make-leaf
+ (make-record key data)))
+ (node-insert
+ key data (left-branch node))))
+ ((funcall <? cur-key key)
+ (if (null (right-branch node))
+ (set-right-branch!
+ node
+ (make-leaf
+ (make-record key data)))
+ (node-insert
+ key data (right-branch node))))
+ (t ;equal
+ (set-entry!
+ node (make-record key data))))))
+ (insert! (key data)
+ (if (null (tree-root))
+ (set-tree-root!
+ (make-leaf (make-record key data)))
+ (node-insert key data (tree-root))))
+ (dispatch (m)
+ (case m
+ ('lookup-proc #'lookup)
+ ('insert-proc! #'insert!)
+ (otherwise (error "Bad dispatch ~a" m)))))
+ #'dispatch)))
+
blob - /dev/null
blob + e13f5bf561f7459032649937f582be19b01688ad (mode 644)
--- /dev/null
+++ ex3-26.lisp~
+(defun make-tree (entry left right)
+ (list entry left right))
+(defun make-leaf (entry)
+ (list entry nil nil))
+(defun entry (tree)
+ (car tree))
+(defun set-entry! (tree ent)
+ (setf (car tree) ent))
+(defun left-branch (tree)
+ (cadr tree))
+(defun set-let-branch! (tree lb)
+ (setf (cadr tree) lb))
+(defun right-branch (tree)
+ (caddr tree))
+(defun set-right-branch! (tree lb)
+ (setf (caddr tree) lb))
+
+(defun make-record (key data)
+ (list key data))
+(defun key (record)
+ (car record))
+(defun data (record)
+ (cadr record))
+(defun make-table (&key (<? #'<))
+ (let ((local-table (cons '*head* nil)))
+ (labels (
+ (tree-root ()
+ (cdr local-table))
+ (set-tree-root! (node)
+ (setf (cdr local-table) node))
+ (node-lookup (key node)
+ (if (null node)
+ nil
+ (let* ((cur-entry (entry node))
+ (cur-key (key cur-entry)))
+ (cond ((funcall <? key cur-key)
+ (node-lookup
+ key
+ (left-branch node)))
+ ((funcall <? cur-key key)
+ (node-lookup
+ key
+ (right-branch node)))
+ (t
+ cur-entry))))))
blob - /dev/null
blob + fd64a48a6f35c705870574896db72ebea0f49308 (mode 644)
--- /dev/null
+++ ex3-26.scm
+;; Exercise 3.26. To search a table as implemented above, one needs to scan through the list of records. This is basically the unordered list representation of section 2.3.3. For large tables, it may be more efficient to structure the table in a different manner. Describe a table implementation where the (key, value) records are organized using a binary tree, assuming that keys can be ordered in some way (e.g., numerically or alphabetically). (Compare exercise 2.66 of chapter 2.)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (make-tree key value)
+ (list key value '() '()))
+(define (tree-key tree)
+ (car tree))
+(define (tree-value tree)
+ (cadr tree))
+(define (left-branch tree)
+ (caddr tree))
+(define (right-branch tree)
+ (cadddr tree))
+(define (set-tree-value! tree value)
+ (set-car! (cdr tree) value))
+(define (insert-left-branch! tree key value)
+ (set-car! (cddr tree)
+ (make-tree key value)))
+(define (insert-right-branch! tree key value)
+ (set-car! (cdddr tree)
+ (make-tree key value)))
+
+;; (define family-tree (make-tree 'me 'aaron))
+;; (insert-left-branch! family-tree 'mom 'amy)
+;; (insert-right-branch! family-tree 'dad 'james)
+;; (insert-left-branch! (left-branch family-tree) 'grandma '?)
+;; (insert-right-branch! (left-branch family-tree) 'grandpa 'sean)
+;; (insert-left-branch! (right-branch family-tree) 'grandma '??)
+;; (insert-right-branch! (right-branch family-tree) 'grandpa 'yuandu)
+;; (test-case (tree-value (right-branch (left-branch family-tree))) 'sean)
+;; (test-case (tree-key (left-branch (right-branch family-tree))) 'grandma)
+;; (test-case (tree-value (right-branch family-tree)) 'james)
+;; (set-tree-value! (right-branch family-tree) 'chen-min)
+;; (test-case (tree-value (right-branch family-tree)) 'chen-min)
+
+(define (make-table less-thanp)
+ (let ((local-table '()))
+ (define (assoc key tree)
+ (cond ((null? tree) false)
+ ((less-thanp key (tree-key tree)) (assoc key (left-branch tree)))
+ ((less-thanp (tree-key tree) key) (assoc key (right-branch tree)))
+ (else tree))) ;; equality
+ (define (lookup key)
+ (let ((match (assoc key local-table)))
+ (if match
+ (tree-value match)
+ false)))
+ (define (insert! key value)
+ (define (insert-tree! tree)
+ (if (equalp key (tree-key tree))
+ (set-tree-value! tree value)
+ (if (less-thanp key (tree-key tree))
+ (if (null? (left-branch tree))
+ (insert-left-branch! tree key value)
+ (insert-tree! (left-branch tree)))
+ (if (null? (right-branch tree))
+ (insert-right-branch! tree key value)
+ (insert-tree! (right-branch tree))))))
+ (if (null? local-table)
+ (set! local-table (make-tree key value))
+ (insert-tree! local-table)))
+ (define (dispatch m)
+ (cond ((eq? m 'lookup) lookup)
+ ((eq? m 'insert!) insert!)
+ ((eq? m 'debug-print) local-table)
+ (else (error "Unknown request -- MAKE-TABLE" m))))
+ dispatch))
+
+(define (insert! key value table)
+ ((table 'insert!) key value))
+(define (lookup key table)
+ ((table 'lookup) key))
+
+(define israel-sons (make-table = <))
+(insert! 3 'levi israel-sons)
+(insert! 5 'dan israel-sons)
+(test-case (lookup 3 israel-sons) 'levi)
+(test-case (lookup 5 israel-sons) 'dan)
+(test-case (lookup 12 israel-sons) false)
+(test-case (lookup 11 israel-sons) false)
+(test-case (lookup 1 israel-sons) false)
+(insert! 12 'benjamin israel-sons)
+(insert! 11 'joseph israel-sons)
+(insert! 1 'reuben israel-sons)
+(test-case (lookup 12 israel-sons) 'benjamin)
+(test-case (lookup 11 israel-sons) 'joseph)
+(test-case (lookup 1 israel-sons) 'reuben)
+(insert! 2 'simeon israel-sons)
+(test-case (lookup 3 israel-sons) 'levi)
+(insert! 8 'asher israel-sons)
+(insert! 7 'gad israel-sons)
+(insert! 6 'naphtali israel-sons)
+(insert! 9 'issachar israel-sons)
+(insert! 10 'zebulun israel-sons)
+(insert! 4 'judah israel-sons)
+(test-case (lookup 4 israel-sons) 'judah)
+(test-case (lookup 8 israel-sons) 'asher)
+(test-case (lookup 13 israel-sons) false)
+(insert! 12 'manasseh israel-sons)
+(insert! 13 'ephraim israel-sons)
+(insert! 11 'benjamin israel-sons)
+(test-case (lookup 12 israel-sons) 'manasseh)
+(test-case (lookup 13 israel-sons) 'ephraim)
+(test-case (israel-sons 'debug-print)
+ '(3 levi (1 reuben () (2 simeon () ())) (5 dan (4 judah () ()) (12 manasseh (11 benjamin (8 asher (7 gad (6 naphtali () ()) ()) (9 issachar () (10 zebulun () ()))) ()) (13 ephraim () ())))))
+
+(define by-mother (make-table string=? string<?))
+(insert! "leah" 'reuben by-mother)
+(test-case (lookup "leah" by-mother) 'reuben)
+(insert! "leah" 'simeon by-mother)
+(test-case (lookup "leah" by-mother) 'simeon)
+(insert! "zilpah" 'gad by-mother)
+(insert! "bilhah" 'dan by-mother)
+(insert! "rachel" 'joseph by-mother)
+(test-case (lookup "zilpah" by-mother) 'gad)
+(test-case (lookup "bilhah" by-mother) 'dan)
+(test-case (lookup "rachel" by-mother) 'joseph)
+
blob - /dev/null
blob + bc6deda2e18d66fba63cbd8f77380db710af375b (mode 644)
--- /dev/null
+++ ex3-26.scm~
+;; Exercise 3.26. To search a table as implemented above, one needs to scan through the list of records. This is basically the unordered list representation of section 2.3.3. For large tables, it may be more efficient to structure the table in a different manner. Describe a table implementation where the (key, value) records are organized using a binary tree, assuming that keys can be ordered in some way (e.g., numerically or alphabetically). (Compare exercise 2.66 of chapter 2.)
+
+
+(define (make-tree key value left right)
+ (list key value left right))
+(define (key tree)
+ (car tree))
+(define (value tree)
+ (cadr tree)
+(define (left-branch tree)
+ (caddr tree))
+(define (right-branch tree)
+ (cadddr tree))
+
+(define (make-table)
+ (make-tree '*table* '() '()))
+
+(define (assoc key tree)
+ (cond ((null? tree) (error "assoc passed empty tree"))
+ ((= key (entry tree)) tree)
+ ((< key (entry tree)) ...)
+ (else ...)))
+
+
+(define (insert! key value table)
+ (
blob - /dev/null
blob + 00c53b273575cb0c800970a0424d465a0f0f6aa0 (mode 644)
--- /dev/null
+++ ex3-27.scm
+(define (lookup key table)
+ (let ((record (assoc key (cdr table))))
+ (if record
+ (cdr record)
+ false)))
+(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+(define (insert! key value table)
+ (let ((record (assoc key (cdr table))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! table
+ (cons (cons key value) (cdr table)))))
+ 'ok)
+(define (make-table)
+ (list '*table*))
+
+(define (fib n)
+ (cond ((= n 0) 0)
+ ((= n 1) 1)
+ (else (+ (fib (- n 1))
+ (fib (- n 2))))))
+
+(define (memoize f)
+ (let ((local-table (make-table)))
+ (lambda (x)
+ (or (lookup x local-table)
+ (let ((result (f x)))
+ (insert! x result local-table)
+ result)))))
+
+(define memo-fib
+ (memoize
+ (lambda (n)
+ (cond ((= n 0) 0)
+ ((= n 1) 1)
+ (else (+ (memo-fib (- n 1))
+ (memo-fib (- n 2))))))))
+
+(memo-fib 5000)
+;;(fib 100)
+
+;; Draw an environment diagram to analyze the computation of (memo-fib 3). Explain why memo-fib computes the nth Fibonacci number in a number of steps proportional to n. Would the scheme still work if we had simply defined memo-fib to be (memoize fib)?
+
+;; each fibonacci number is only calculated once because the argument and resulting value is stored in the table and looked up whenever possible
+;; No, the scheme would not work if we had defined memo-fib to be (memoize fib). This is because, while (memo-fib 3) looks up values in the table and attempts to record its calculations in the table, when it is discovered that the 3rd fibonacci number is not in the table, (fib 2) and (fib 1) are calculated. fib has, as its enclosing environment, the global environment. So, it cannot look up nor add entries to the table (the procedure for fib also never uses the table).
blob - /dev/null
blob + 33d7f5c262cae3e81d2b52461155dbfb21acd387 (mode 644)
--- /dev/null
+++ ex3-27.scm~
+;; Draw an environment diagram to analyze the computation of (memo-fib 3). Explain why memo-fib computes the nth Fibonacci number in a number of steps proportional to n. Would the scheme still work if we had simply defined memo-fib to be (memoize fib)?
+
+;; each fibonacci number is only calculated once because the argument and resulting value is stored in the table and looked up whenever possible
+;;
blob - /dev/null
blob + be4c9afd59e23dcfb31960891ea14813cb42694d (mode 644)
--- /dev/null
+++ ex3-28.scm
+;; Exercise 3.28. Define an or-gate as a primitive function box. Your or-gate constructor should be similar to and-gate.
+
+(define (half-adder a b s c)
+ (let ((d (make-wire)) (e (make-wire)))
+ (or-gate a b d)
+ (and-gate a b c)
+ (inverter c e)
+ (and-gate d e s)
+ 'ok))
+(define (full-adder a b c-in sum c-out)
+ (let ((s (make-wire))
+ (c1 (make-wire))
+ (c2 (make-wire)))
+ (half-adder b c-in s c1)
+ (half-adder a s sum c2)
+ (or-gate c1 c2 c-out)
+ 'ok))
+(define (inverter input output)
+ (define (invert-input)
+ (let ((new-value (logical-not (get-signal input))))
+ (after-delay inverter-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! input invert-input)
+ 'ok)
+(define (logical-not s)
+ (cond ((= s 0) 1)
+ ((= s 1) 0)
+ (else (error "Invalid signal" s))))
+
+(define (and-gate a1 a2 output)
+ (define (logical-and x y)
+ (* x y))
+ (define (and-action-procedure)
+ (let ((new-value
+ (logical-and (get-signal a1) (get-signal a2))))
+ (after-delay and-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 and-action-procedure)
+ (add-action! a2 and-action-procedure)
+ 'ok)
+(define (make-wire)
+ (let ((signal-value 0) (action-procedures '()))
+ (define (set-my-signal! new-value)
+ (if (not (= signal-value new-value))
+ (begin (set! signal-value new-value)
+ (call-each action-procedures))
+ 'done))
+ (define (accept-action-procedure! proc)
+ (set! action-procedures (cons proc action-procedures))
+ (proc))
+ (define (dispatch m)
+ (cond ((eq? m 'get-signal) signal-value)
+ ((eq? m 'set-signal!) set-my-signal!)
+ ((eq? m 'add-action!) accept-action-procedure!)
+ (else (error "Unknown operation -- WIRE" m))))
+ dispatch))
+(define (call-each procedures)
+ (if (null? procedures)
+ 'done
+ (begin
+ ((car procedures))
+ (call-each (cdr procedures)))))
+(define (get-signal wire)
+ (wire 'get-signal))
+(define (set-signal! wire new-value)
+ ((wire 'set-signal!) new-value))
+(define (add-action! wire action-procedure)
+ ((wire 'add-action!) action-procedure))
+(define (after-delay delay action)
+ (add-to-agenda! (+ delay (current-time the-agenda))
+ action
+ the-agenda))
+(define (propagate)
+ (if (empty-agenda? the-agenda)
+ 'done
+ (let ((first-item (first-agenda-item the-agenda)))
+ (first-item)
+ (remove-first-agenda-item! the-agenda)
+ (propagate))))
+(define (probe name wire)
+ (add-action! wire
+ (lambda ()
+ (newline)
+ (display name)
+ (display " ")
+ (display (current-time the-agenda))
+ (display " New-value = ")
+ (display (get-signal wire)))))
+(define inverter-delay 2)
+(define and-gate-delay 3)
+(define or-gate-delay 5)
+(define input-1 (make-wire))
+(define input-2 (make-wire))
+(define sum (make-wire))
+(define carry (make-wire))
+(define (make-time-segment time queue)
+ (cons time queue))
+(define (segment-time s) (car s))
+(define (segment-queue s) (cdr s))
+(define (make-agenda) (list 0))
+(define the-agenda (make-agenda))
+(define (current-time agenda) (car agenda))
+(define (set-current-time! agenda time)
+ (set-car! agenda time))
+(define (segments agenda) (cdr agenda))
+(define (set-segments! agenda segments)
+ (set-cdr! agenda segments))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segments agenda)))
+(define (empty-agenda? agenda)
+ (null? (segments agenda)))
+(define (add-to-agenda! time action agenda)
+ (define (belongs-before? segments)
+ (or (null? segments)
+ (< time (segment-time (car segments)))))
+ (define (make-new-time-segment time action)
+ (let ((q (make-queue)))
+ (insert-queue! q action)
+ (make-time-segment time q)))
+ (define (add-to-segments! segments)
+ (if (= (segment-time (car segments)) time)
+ (insert-queue! (segment-queue (car segments))
+ action)
+ (let ((rest (cdr segments)))
+ (if (belongs-before? rest)
+ (set-cdr!
+ segments
+ (cons (make-new-time-segment time action)
+ (cdr segments)))
+ (add-to-segments! rest)))))
+ (let ((segments (segments agenda)))
+ (if (belongs-before? segments)
+ (set-segments!
+ agenda
+ (cons (make-new-time-segment time action)
+ segments))
+ (add-to-segments! segments))))
+(define (remove-first-agenda-item! agenda)
+ (let ((q (segment-queue (first-segment agenda))))
+ (delete-queue! q)
+ (if (empty-queue? q)
+ (set-segments! agenda (rest-segments agenda)))))
+(define (first-agenda-item agenda)
+ (if (empty-agenda? agenda)
+ (error "Agenda is empty -- FIRST-AGENDA-ITEM")
+ (let ((first-seg (first-segment agenda)))
+ (set-current-time! agenda (segment-time first-seg))
+ (front-queue (segment-queue first-seg)))))
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (make-queue) (cons '() '()))(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+;; solution
+
+(define (or-gate a1 a2 output)
+ (define (logical-or x y)
+ (if (or (= x 1) (= y 1))
+ 1
+ 0))
+ (define (or-action-procedure)
+ (let ((new-value (logical-or (get-signal a1) (get-signal a2))))
+ (after-delay or-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 or-action-procedure)
+ (add-action! a2 or-action-procedure)
+ 'ok)
+
+(define in-wire1 (make-wire))
+(define in-wire2 (make-wire))
+(define out-wire (make-wire))
+(probe 'in-wire1 in-wire1)
+(probe 'in-wire2 in-wire2)
+(probe 'out-wire out-wire)
+(or-gate in-wire1 in-wire2 out-wire)
+(propagate)
+(set-signal! in-wire1 1)
+(propagate)
+(set-signal! in-wire2 1)
+(propagate)
+(set-signal! in-wire1 0)
+(propagate)
+(set-signal! in-wire2 0)
+(propagate)
blob - /dev/null
blob + 616e56f457c3f4fb7f2b04f8011c0dde8ea7b857 (mode 644)
--- /dev/null
+++ ex3-28.scm~
+;; Exercise 3.28. Define an or-gate as a primitive function box. Your or-gate constructor should be similar to and-gate.
+
+(define (half-adder a b s c)
+ (let ((d (make-wire)) (e (make-wire)))
+ (or-gate a b d)
+ (and-gate a b c)
+ (inverter c e)
+ (and-gate d e s)
+ 'ok))
+
+(define (full-adder a b c-in sum c-out)
+ (let ((s (make-wire))
+ (c1 (make-wire))
+ (c2 (make-wire)))
+ (half-adder b c-in s c1)
+ (half-adder a s sum c2)
+ (or-gate c1 c2 c-out)
+ 'ok))
+
+
+
+
+(define (inverter input output)
+ (define (invert-input)
+ (let ((new-value (logical-not (get-signal input))))
+ (after-delay inverter-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! input invert-input)
+ 'ok)
+(define (logical-not s)
+ (cond ((= s 0) 1)
+ ((= s 1) 0)
+ (else (error "Invalid signal" s))))
+
+(define (and-gate a1 a2 output)
+ (define (and-action-procedure)
+ (let ((new-value
+ (logical-and (get-signal a1) (get-signal a2))))
+ (after-delay and-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 and-action-procedure)
+ (add-action! a2 and-action-procedure)
+ 'ok)
+
+
+(define (make-wire)
+ (let ((signal-value 0) (action-procedures '()))
+ (define (set-my-signal! new-value)
+ (if (not (= signal-value new-value))
+ (begin (set! signal-value new-value)
+ (call-each action-procedures))
+ 'done))
+ (define (accept-action-procedure! proc)
+ (set! action-procedures (cons proc action-procedures))
+ (proc))
+ (define (dispatch m)
+ (cond ((eq? m 'get-signal) signal-value)
+ ((eq? m 'set-signal!) set-my-signal!)
+ ((eq? m 'add-action!) accept-action-procedure!)
+ (else (error "Unknown operation -- WIRE" m))))
+ dispatch))
+
+
+(define (call-each procedures)
+ (if (null? procedures)
+ 'done
+ (begin
+ ((car procedures))
+ (call-each (cdr procedures)))))
+(define (get-signal wire)
+ (wire 'get-signal))
+(define (set-signal! wire new-value)
+ ((wire 'set-signal!) new-value))
+(define (add-action! wire action-procedure)
+ ((wire 'add-action!) action-procedure))
+
+
+
+
+(define (after-delay delay action)
+ (add-to-agenda! (+ delay (current-time the-agenda))
+ action
+ the-agenda))
+(define (propagate)
+ (if (empty-agenda? the-agenda)
+ 'done
+ (let ((first-item (first-agenda-item the-agenda)))
+ (first-item)
+ (remove-first-agenda-item! the-agenda)
+ (propagate))))
+
+
+(define (probe name wire)
+ (add-action! wire
+ (lambda ()
+ (newline)
+ (display name)
+ (display " ")
+ (display (current-time the-agenda))
+ (display " New-value = ")
+ (display (get-signal wire)))))
+(define the-agenda (make-agenda))
+(define inverter-delay 2)
+(define and-gate-delay 3)
+(define or-gate-delay 5)
+(define input-1 (make-wire))
+(define input-2 (make-wire))
+(define sum (make-wire))
+(define carry (make-wire))
+(probe 'sum sum)
+sum 0 New-value = 0
+(probe 'carry carry)
+carry 0 New-value = 0
+
+
+(define (make-time-segment time queue)
+ (cons time queue))
+(define (segment-time s) (car s))
+(define (segment-queue s) (cdr s))
+(define (make-agenda) (list 0))
+(define (current-time agenda) (car agenda))
+(define (set-current-time! agenda time)
+ (set-car! agenda time))
+(define (segments agenda) (cdr agenda))
+(define (set-segments! agenda segments)
+ (set-cdr! agenda segments))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segments agenda)))
+(define (empty-agenda? agenda)
+ (null? (segments agenda)))
+
+
+(define (add-to-agenda! time action agenda)
+ (define (belongs-before? segments)
+ (or (null? segments)
+ (< time (segment-time (car segments)))))
+ (define (make-new-time-segment time action)
+ (let ((q (make-queue)))
+ (insert-queue! q action)
+ (make-time-segment time q)))
+ (define (add-to-segments! segments)
+ (if (= (segment-time (car segments)) time)
+ (insert-queue! (segment-queue (car segments))
+ action)
+ (let ((rest (cdr segments)))
+ (if (belongs-before? rest)
+ (set-cdr!
+ segments
+ (cons (make-new-time-segment time action)
+ (cdr segments)))
+ (add-to-segments! rest)))))
+ (let ((segments (segments agenda)))
+ (if (belongs-before? segments)
+ (set-segments!
+ agenda
+ (cons (make-new-time-segment time action)
+ segments))
+ (add-to-segments! segments))))
+(define (remove-first-agenda-item! agenda)
+ (let ((q (segment-queue (first-segment agenda))))
+ (delete-queue! q)
+ (if (empty-queue? q)
+ (set-segments! agenda (rest-segments agenda)))))
+(define (first-agenda-item agenda)
+ (if (empty-agenda? agenda)
+ (error "Agenda is empty -- FIRST-AGENDA-ITEM")
+ (let ((first-seg (first-segment agenda)))
+ (set-current-time! agenda (segment-time first-seg))
+ (front-queue (segment-queue first-seg)))))
blob - /dev/null
blob + beb34a4fdb045fe53d41c8a3e5bc34027bddc41a (mode 644)
--- /dev/null
+++ ex3-29.scm
+;; Exercise 3.28. Define an or-gate as a primitive function box. Your or-gate constructor should be similar to and-gate.
+
+(define (half-adder a b s c)
+ (let ((d (make-wire)) (e (make-wire)))
+ (or-gate a b d)
+ (and-gate a b c)
+ (inverter c e)
+ (and-gate d e s)
+ 'ok))
+(define (full-adder a b c-in sum c-out)
+ (let ((s (make-wire))
+ (c1 (make-wire))
+ (c2 (make-wire)))
+ (half-adder b c-in s c1)
+ (half-adder a s sum c2)
+ (or-gate c1 c2 c-out)
+ 'ok))
+(define (inverter input output)
+ (define (invert-input)
+ (let ((new-value (logical-not (get-signal input))))
+ (after-delay inverter-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! input invert-input)
+ 'ok)
+(define (logical-not s)
+ (cond ((= s 0) 1)
+ ((= s 1) 0)
+ (else (error "Invalid signal" s))))
+
+(define (and-gate a1 a2 output)
+ (define (logical-and x y)
+ (* x y))
+ (define (and-action-procedure)
+ (let ((new-value
+ (logical-and (get-signal a1) (get-signal a2))))
+ (after-delay and-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 and-action-procedure)
+ (add-action! a2 and-action-procedure)
+ 'ok)
+(define (make-wire)
+ (let ((signal-value 0) (action-procedures '()))
+ (define (set-my-signal! new-value)
+ (if (not (= signal-value new-value))
+ (begin (set! signal-value new-value)
+ (call-each action-procedures))
+ 'done))
+ (define (accept-action-procedure! proc)
+ (set! action-procedures (cons proc action-procedures))
+ (proc))
+ (define (dispatch m)
+ (cond ((eq? m 'get-signal) signal-value)
+ ((eq? m 'set-signal!) set-my-signal!)
+ ((eq? m 'add-action!) accept-action-procedure!)
+ (else (error "Unknown operation -- WIRE" m))))
+ dispatch))
+(define (call-each procedures)
+ (if (null? procedures)
+ 'done
+ (begin
+ ((car procedures))
+ (call-each (cdr procedures)))))
+(define (get-signal wire)
+ (wire 'get-signal))
+(define (set-signal! wire new-value)
+ ((wire 'set-signal!) new-value))
+(define (add-action! wire action-procedure)
+ ((wire 'add-action!) action-procedure))
+(define (after-delay delay action)
+ (add-to-agenda! (+ delay (current-time the-agenda))
+ action
+ the-agenda))
+(define (propagate)
+ (if (empty-agenda? the-agenda)
+ 'done
+ (let ((first-item (first-agenda-item the-agenda)))
+ (first-item)
+ (remove-first-agenda-item! the-agenda)
+ (propagate))))
+(define (probe name wire)
+ (add-action! wire
+ (lambda ()
+ (newline)
+ (display name)
+ (display " ")
+ (display (current-time the-agenda))
+ (display " New-value = ")
+ (display (get-signal wire)))))
+(define inverter-delay 2)
+(define and-gate-delay 3)
+(define or-gate-delay 5)
+(define input-1 (make-wire))
+(define input-2 (make-wire))
+(define sum (make-wire))
+(define carry (make-wire))
+(define (make-time-segment time queue)
+ (cons time queue))
+(define (segment-time s) (car s))
+(define (segment-queue s) (cdr s))
+(define (make-agenda) (list 0))
+(define the-agenda (make-agenda))
+(define (current-time agenda) (car agenda))
+(define (set-current-time! agenda time)
+ (set-car! agenda time))
+(define (segments agenda) (cdr agenda))
+(define (set-segments! agenda segments)
+ (set-cdr! agenda segments))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segments agenda)))
+(define (empty-agenda? agenda)
+ (null? (segments agenda)))
+(define (add-to-agenda! time action agenda)
+ (define (belongs-before? segments)
+ (or (null? segments)
+ (< time (segment-time (car segments)))))
+ (define (make-new-time-segment time action)
+ (let ((q (make-queue)))
+ (insert-queue! q action)
+ (make-time-segment time q)))
+ (define (add-to-segments! segments)
+ (if (= (segment-time (car segments)) time)
+ (insert-queue! (segment-queue (car segments))
+ action)
+ (let ((rest (cdr segments)))
+ (if (belongs-before? rest)
+ (set-cdr!
+ segments
+ (cons (make-new-time-segment time action)
+ (cdr segments)))
+ (add-to-segments! rest)))))
+ (let ((segments (segments agenda)))
+ (if (belongs-before? segments)
+ (set-segments!
+ agenda
+ (cons (make-new-time-segment time action)
+ segments))
+ (add-to-segments! segments))))
+(define (remove-first-agenda-item! agenda)
+ (let ((q (segment-queue (first-segment agenda))))
+ (delete-queue! q)
+ (if (empty-queue? q)
+ (set-segments! agenda (rest-segments agenda)))))
+(define (first-agenda-item agenda)
+ (if (empty-agenda? agenda)
+ (error "Agenda is empty -- FIRST-AGENDA-ITEM")
+ (let ((first-seg (first-segment agenda)))
+ (set-current-time! agenda (segment-time first-seg))
+ (front-queue (segment-queue first-seg)))))
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (make-queue) (cons '() '()))(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+
+;; (define (or-gate a1 a2 output)
+;; (define (logical-or x y)
+;; (if (or (= x 1) (= y 1))
+;; 1
+;; 0))
+;; (define (or-action-procedure)
+;; (let ((new-value (logical-or (get-signal a1) (get-signal a2))))
+;; (after-delay or-gate-delay
+;; (lambda ()
+;; (set-signal! output new-value)))))
+;; (add-action! a1 or-action-procedure)
+;; (add-action! a2 or-action-procedure)
+;; 'ok)
+
+;; Exercise 3.29. Another way to construct an or-gate is as a compound digital logic device, built from and-gates and inverters. Define a procedure or-gate that accomplishes this. What is the delay time of the or-gate in terms of and-gate-delay and inverter-delay?
+
+(define (or-gate a1 a2 output)
+ (let ((b1 (make-wire))
+ (b2 (make-wire))
+ (c (make-wire)))
+ (set-signal! b1 1)
+ (set-signal! b2 1)
+ (set-signal! c 1)
+ (inverter a1 b1)
+ (inverter a2 b2)
+ (and-gate b1 b2 c)
+ (inverter c output)))
+
+(define in-wire1 (make-wire))
+(define in-wire2 (make-wire))
+(define out-wire (make-wire))
+(probe 'in-wire1 in-wire1)
+(probe 'in-wire2 in-wire2)
+(probe 'out-wire out-wire)
+(or-gate in-wire1 in-wire2 out-wire)
+(propagate)
+(set-signal! in-wire1 1)
+(propagate)
+(set-signal! in-wire2 1)
+(propagate)
+(set-signal! in-wire1 0)
+(propagate)
+(set-signal! in-wire2 0)
+(propagate)
+
+;; the delay is roughly 2*inverter-delay + 1 and-gate-delay
+
blob - /dev/null
blob + be4c9afd59e23dcfb31960891ea14813cb42694d (mode 644)
--- /dev/null
+++ ex3-29.scm~
+;; Exercise 3.28. Define an or-gate as a primitive function box. Your or-gate constructor should be similar to and-gate.
+
+(define (half-adder a b s c)
+ (let ((d (make-wire)) (e (make-wire)))
+ (or-gate a b d)
+ (and-gate a b c)
+ (inverter c e)
+ (and-gate d e s)
+ 'ok))
+(define (full-adder a b c-in sum c-out)
+ (let ((s (make-wire))
+ (c1 (make-wire))
+ (c2 (make-wire)))
+ (half-adder b c-in s c1)
+ (half-adder a s sum c2)
+ (or-gate c1 c2 c-out)
+ 'ok))
+(define (inverter input output)
+ (define (invert-input)
+ (let ((new-value (logical-not (get-signal input))))
+ (after-delay inverter-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! input invert-input)
+ 'ok)
+(define (logical-not s)
+ (cond ((= s 0) 1)
+ ((= s 1) 0)
+ (else (error "Invalid signal" s))))
+
+(define (and-gate a1 a2 output)
+ (define (logical-and x y)
+ (* x y))
+ (define (and-action-procedure)
+ (let ((new-value
+ (logical-and (get-signal a1) (get-signal a2))))
+ (after-delay and-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 and-action-procedure)
+ (add-action! a2 and-action-procedure)
+ 'ok)
+(define (make-wire)
+ (let ((signal-value 0) (action-procedures '()))
+ (define (set-my-signal! new-value)
+ (if (not (= signal-value new-value))
+ (begin (set! signal-value new-value)
+ (call-each action-procedures))
+ 'done))
+ (define (accept-action-procedure! proc)
+ (set! action-procedures (cons proc action-procedures))
+ (proc))
+ (define (dispatch m)
+ (cond ((eq? m 'get-signal) signal-value)
+ ((eq? m 'set-signal!) set-my-signal!)
+ ((eq? m 'add-action!) accept-action-procedure!)
+ (else (error "Unknown operation -- WIRE" m))))
+ dispatch))
+(define (call-each procedures)
+ (if (null? procedures)
+ 'done
+ (begin
+ ((car procedures))
+ (call-each (cdr procedures)))))
+(define (get-signal wire)
+ (wire 'get-signal))
+(define (set-signal! wire new-value)
+ ((wire 'set-signal!) new-value))
+(define (add-action! wire action-procedure)
+ ((wire 'add-action!) action-procedure))
+(define (after-delay delay action)
+ (add-to-agenda! (+ delay (current-time the-agenda))
+ action
+ the-agenda))
+(define (propagate)
+ (if (empty-agenda? the-agenda)
+ 'done
+ (let ((first-item (first-agenda-item the-agenda)))
+ (first-item)
+ (remove-first-agenda-item! the-agenda)
+ (propagate))))
+(define (probe name wire)
+ (add-action! wire
+ (lambda ()
+ (newline)
+ (display name)
+ (display " ")
+ (display (current-time the-agenda))
+ (display " New-value = ")
+ (display (get-signal wire)))))
+(define inverter-delay 2)
+(define and-gate-delay 3)
+(define or-gate-delay 5)
+(define input-1 (make-wire))
+(define input-2 (make-wire))
+(define sum (make-wire))
+(define carry (make-wire))
+(define (make-time-segment time queue)
+ (cons time queue))
+(define (segment-time s) (car s))
+(define (segment-queue s) (cdr s))
+(define (make-agenda) (list 0))
+(define the-agenda (make-agenda))
+(define (current-time agenda) (car agenda))
+(define (set-current-time! agenda time)
+ (set-car! agenda time))
+(define (segments agenda) (cdr agenda))
+(define (set-segments! agenda segments)
+ (set-cdr! agenda segments))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segments agenda)))
+(define (empty-agenda? agenda)
+ (null? (segments agenda)))
+(define (add-to-agenda! time action agenda)
+ (define (belongs-before? segments)
+ (or (null? segments)
+ (< time (segment-time (car segments)))))
+ (define (make-new-time-segment time action)
+ (let ((q (make-queue)))
+ (insert-queue! q action)
+ (make-time-segment time q)))
+ (define (add-to-segments! segments)
+ (if (= (segment-time (car segments)) time)
+ (insert-queue! (segment-queue (car segments))
+ action)
+ (let ((rest (cdr segments)))
+ (if (belongs-before? rest)
+ (set-cdr!
+ segments
+ (cons (make-new-time-segment time action)
+ (cdr segments)))
+ (add-to-segments! rest)))))
+ (let ((segments (segments agenda)))
+ (if (belongs-before? segments)
+ (set-segments!
+ agenda
+ (cons (make-new-time-segment time action)
+ segments))
+ (add-to-segments! segments))))
+(define (remove-first-agenda-item! agenda)
+ (let ((q (segment-queue (first-segment agenda))))
+ (delete-queue! q)
+ (if (empty-queue? q)
+ (set-segments! agenda (rest-segments agenda)))))
+(define (first-agenda-item agenda)
+ (if (empty-agenda? agenda)
+ (error "Agenda is empty -- FIRST-AGENDA-ITEM")
+ (let ((first-seg (first-segment agenda)))
+ (set-current-time! agenda (segment-time first-seg))
+ (front-queue (segment-queue first-seg)))))
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (make-queue) (cons '() '()))(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+;; solution
+
+(define (or-gate a1 a2 output)
+ (define (logical-or x y)
+ (if (or (= x 1) (= y 1))
+ 1
+ 0))
+ (define (or-action-procedure)
+ (let ((new-value (logical-or (get-signal a1) (get-signal a2))))
+ (after-delay or-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 or-action-procedure)
+ (add-action! a2 or-action-procedure)
+ 'ok)
+
+(define in-wire1 (make-wire))
+(define in-wire2 (make-wire))
+(define out-wire (make-wire))
+(probe 'in-wire1 in-wire1)
+(probe 'in-wire2 in-wire2)
+(probe 'out-wire out-wire)
+(or-gate in-wire1 in-wire2 out-wire)
+(propagate)
+(set-signal! in-wire1 1)
+(propagate)
+(set-signal! in-wire2 1)
+(propagate)
+(set-signal! in-wire1 0)
+(propagate)
+(set-signal! in-wire2 0)
+(propagate)
blob - /dev/null
blob + 5209004207a3462676a27bd308657356af740795 (mode 644)
--- /dev/null
+++ ex3-30-2.scm
+(define (ripple-carry-adder A B S C)
+ (let ((c-in (make-wire)))
+ (if (null? (cdr A))
+ (set-signal! c-in 0)
+ (ripple-carry-adder (cdr A) (cdr B) (cdr S) c-in))
+ (full-adder (car A) (car B) c-in (car S) C)))
blob - /dev/null
blob + f85ec7ca111f1dc5adbb73b32ae9093e1f45aecc (mode 644)
--- /dev/null
+++ ex3-30.lisp
+(defun ripple-carry-adder (la lb ls c)
+ (let ((n (length la)))
+ (unless (= n (length lb) (length ls))
+ (error "Expecting all lists of same length"))
+ (labels ((ripple-build (la lb lcin ls lcout)
+ (unless (null la)
+ (full-adder (car la) (car lb) (car lcin)
+ (car ls) (car lcout))
+ (ripple-build (cdr la) (cdr lb) (cdr lcin)
+ (cdr ls) (cdr lcout)))))
+ (let ((lcin '()) (lcout '()))
+ (dotimes (i n)
+ (let ((ci (make-wire)))
+ (push ci lcin)
+ (push ci lcout)))
+ (push c lcout)
+ (ripple-build la lb lcin ls lcout)))))
blob - /dev/null
blob + 5826bdd1e886cf0dc7106851f1a8fb8e21a6d115 (mode 644)
--- /dev/null
+++ ex3-30.lisp~
+(defun ripple-carry-adder (la lb ls c)
+ (let ((n (length la)))
+ (unless (= n (length lb) (length ls))
+ (error "Expecting all lists of same length"))
+ (labels ((ripple-build (la lb lcin ls lcout)
+ (unless (null la)
+ (full-adder (car la) (car lb) (car lcin)
+ (car ls) (car lcout))
+ (ripple-build (cdr la) (cdr lb) (cdr lcin)
+ (cdr ls) (cdr lcout)))))
blob - /dev/null
blob + 957602e62dbd7b17e18c975a30a18c23ed92a2ea (mode 644)
--- /dev/null
+++ ex3-30.scm
+;; Exercise 3.28. Define an or-gate as a primitive function box. Your or-gate constructor should be similar to and-gate.
+
+(define (half-adder a b s c)
+ (let ((d (make-wire)) (e (make-wire)))
+ (or-gate a b d)
+ (and-gate a b c)
+ (inverter c e)
+ (and-gate d e s)
+ 'ok))
+(define (full-adder a b c-in sum c-out)
+ (let ((s (make-wire))
+ (c1 (make-wire))
+ (c2 (make-wire)))
+ (half-adder b c-in s c1)
+ (half-adder a s sum c2)
+ (or-gate c1 c2 c-out)
+ 'ok))
+(define (inverter input output)
+ (define (invert-input)
+ (let ((new-value (logical-not (get-signal input))))
+ (after-delay inverter-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! input invert-input)
+ 'ok)
+(define (logical-not s)
+ (cond ((= s 0) 1)
+ ((= s 1) 0)
+ (else (error "Invalid signal" s))))
+
+(define (and-gate a1 a2 output)
+ (define (logical-and x y)
+ (* x y))
+ (define (and-action-procedure)
+ (let ((new-value
+ (logical-and (get-signal a1) (get-signal a2))))
+ (after-delay and-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 and-action-procedure)
+ (add-action! a2 and-action-procedure)
+ 'ok)
+(define (make-wire)
+ (let ((signal-value 0) (action-procedures '()))
+ (define (set-my-signal! new-value)
+ (if (not (= signal-value new-value))
+ (begin (set! signal-value new-value)
+ (call-each action-procedures))
+ 'done))
+ (define (accept-action-procedure! proc)
+ (set! action-procedures (cons proc action-procedures))
+ (proc))
+ (define (dispatch m)
+ (cond ((eq? m 'get-signal) signal-value)
+ ((eq? m 'set-signal!) set-my-signal!)
+ ((eq? m 'add-action!) accept-action-procedure!)
+ (else (error "Unknown operation -- WIRE" m))))
+ dispatch))
+(define (call-each procedures)
+ (if (null? procedures)
+ 'done
+ (begin
+ ((car procedures))
+ (call-each (cdr procedures)))))
+(define (get-signal wire)
+ (wire 'get-signal))
+(define (set-signal! wire new-value)
+ ((wire 'set-signal!) new-value))
+(define (add-action! wire action-procedure)
+ ((wire 'add-action!) action-procedure))
+(define (after-delay delay action)
+ (add-to-agenda! (+ delay (current-time the-agenda))
+ action
+ the-agenda))
+(define (propagate)
+ (if (empty-agenda? the-agenda)
+ 'done
+ (let ((first-item (first-agenda-item the-agenda)))
+ (first-item)
+ (remove-first-agenda-item! the-agenda)
+ (propagate))))
+(define (probe name wire)
+ (add-action! wire
+ (lambda ()
+ (newline)
+ (display name)
+ (display " ")
+ (display (current-time the-agenda))
+ (display " New-value = ")
+ (display (get-signal wire)))))
+(define inverter-delay 2)
+(define and-gate-delay 3)
+(define or-gate-delay 5)
+(define input-1 (make-wire))
+(define input-2 (make-wire))
+(define sum (make-wire))
+(define carry (make-wire))
+(define (make-time-segment time queue)
+ (cons time queue))
+(define (segment-time s) (car s))
+(define (segment-queue s) (cdr s))
+(define (make-agenda) (list 0))
+(define the-agenda (make-agenda))
+(define (current-time agenda) (car agenda))
+(define (set-current-time! agenda time)
+ (set-car! agenda time))
+(define (segments agenda) (cdr agenda))
+(define (set-segments! agenda segments)
+ (set-cdr! agenda segments))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segments agenda)))
+(define (empty-agenda? agenda)
+ (null? (segments agenda)))
+(define (add-to-agenda! time action agenda)
+ (define (belongs-before? segments)
+ (or (null? segments)
+ (< time (segment-time (car segments)))))
+ (define (make-new-time-segment time action)
+ (let ((q (make-queue)))
+ (insert-queue! q action)
+ (make-time-segment time q)))
+ (define (add-to-segments! segments)
+ (if (= (segment-time (car segments)) time)
+ (insert-queue! (segment-queue (car segments))
+ action)
+ (let ((rest (cdr segments)))
+ (if (belongs-before? rest)
+ (set-cdr!
+ segments
+ (cons (make-new-time-segment time action)
+ (cdr segments)))
+ (add-to-segments! rest)))))
+ (let ((segments (segments agenda)))
+ (if (belongs-before? segments)
+ (set-segments!
+ agenda
+ (cons (make-new-time-segment time action)
+ segments))
+ (add-to-segments! segments))))
+(define (remove-first-agenda-item! agenda)
+ (let ((q (segment-queue (first-segment agenda))))
+ (delete-queue! q)
+ (if (empty-queue? q)
+ (set-segments! agenda (rest-segments agenda)))))
+(define (first-agenda-item agenda)
+ (if (empty-agenda? agenda)
+ (error "Agenda is empty -- FIRST-AGENDA-ITEM")
+ (let ((first-seg (first-segment agenda)))
+ (set-current-time! agenda (segment-time first-seg))
+ (front-queue (segment-queue first-seg)))))
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (make-queue) (cons '() '()))(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+(define (or-gate a1 a2 output)
+ (define (logical-or x y)
+ (if (or (= x 1) (= y 1))
+ 1
+ 0))
+ (define (or-action-procedure)
+ (let ((new-value (logical-or (get-signal a1) (get-signal a2))))
+ (after-delay or-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 or-action-procedure)
+ (add-action! a2 or-action-procedure)
+ 'ok)
+
+;; the delay is roughly 2*inverter-delay + 1 and-gate-delay
+
+;; Exercise 3.30. Figure 3.27 shows a ripple-carry adder formed by stringing together n full-adders. This is the simplest form of parallel adder for adding two n-bit binary numbers. The inputs A1, A2, A3, ..., An and B1, B2, B3, ..., Bn are the two binary numbers to be added (each Ak and Bk is a 0 or a 1). The circuit generates S1, S2, S3, ..., Sn, the n bits of the sum, and C, the carry from the addition. Write a procedure ripple-carry-adder that generates this circuit. The procedure should take as arguments three lists of n wires each -- the Ak, the Bk, and the Sk -- and also another wire C. The major drawback of the ripple-carry adder is the need to wait for the carry signals to propagate. What is the delay needed to obtain the complete output from an n-bit ripple-carry adder, expressed in terms of the delays for and-gates, or-gates, and inverters?
+
+(define (ripple-carry-adder a b s c)
+ (if (null? a)
+ 'done
+ (let ((ak (car a))
+ (bk (car b))
+ (sk (car s))
+ (ck (make-wire)))
+ (full-adder ak bk ck sk c)
+ (ripple-carry-adder (cdr a) (cdr b) (cdr s) ck))))
+
+;; returns list of wires with digits
+(define (make-digits digits)
+ (if (null? digits)
+ '()
+ (let ((digit (car digits))
+ (wire (make-wire)))
+ (set-signal! wire digit)
+ (cons wire (make-digits (cdr digits))))))
+
+(define one-three-six (make-digits '(1 0 0 0 1 0 0 0)))
+(define seven-five (make-digits '(0 1 0 0 1 0 1 1)))
+(define sum1 (make-digits '(0 0 0 0 0 0 0 0)))
+(define carry1 (make-wire))
+(ripple-carry-adder one-three-six
+ seven-five
+ sum1
+ carry1)
+(propagate)
+(define two-three-seven (make-digits '(1 1 1 0 1 1 0 1)))
+(define one-nine-eight (make-digits '(1 1 0 0 0 1 1 0)))
+(define sum2 (make-digits '(0 0 0 0 0 0 0 0)))
+(define carry2 (make-wire))
+
+(ripple-carry-adder two-three-seven
+ one-nine-eight
+ sum2
+ carry2)
+(propagate)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(test-case (map get-signal one-three-six) '(1 0 0 0 1 0 0 0))
+(test-case (map get-signal seven-five) '(0 1 0 0 1 0 1 1))
+(test-case (map get-signal sum1) '(1 1 0 1 0 0 1 1))
+(test-case (get-signal carry1) 0)
+
+(test-case (map get-signal two-three-seven) '(1 1 1 0 1 1 0 1))
+(test-case (map get-signal one-nine-eight) '(1 1 0 0 0 1 1 0))
+(test-case (map get-signal sum2) '(1 0 1 1 0 0 1 1))
+(test-case (get-signal carry2) 1)
+
+(define carry3 (make-wire))
+(ripple-carry-adder '() '() '() carry3)
+(test-case (get-signal carry3) 0)
blob - /dev/null
blob + beb34a4fdb045fe53d41c8a3e5bc34027bddc41a (mode 644)
--- /dev/null
+++ ex3-30.scm~
+;; Exercise 3.28. Define an or-gate as a primitive function box. Your or-gate constructor should be similar to and-gate.
+
+(define (half-adder a b s c)
+ (let ((d (make-wire)) (e (make-wire)))
+ (or-gate a b d)
+ (and-gate a b c)
+ (inverter c e)
+ (and-gate d e s)
+ 'ok))
+(define (full-adder a b c-in sum c-out)
+ (let ((s (make-wire))
+ (c1 (make-wire))
+ (c2 (make-wire)))
+ (half-adder b c-in s c1)
+ (half-adder a s sum c2)
+ (or-gate c1 c2 c-out)
+ 'ok))
+(define (inverter input output)
+ (define (invert-input)
+ (let ((new-value (logical-not (get-signal input))))
+ (after-delay inverter-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! input invert-input)
+ 'ok)
+(define (logical-not s)
+ (cond ((= s 0) 1)
+ ((= s 1) 0)
+ (else (error "Invalid signal" s))))
+
+(define (and-gate a1 a2 output)
+ (define (logical-and x y)
+ (* x y))
+ (define (and-action-procedure)
+ (let ((new-value
+ (logical-and (get-signal a1) (get-signal a2))))
+ (after-delay and-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 and-action-procedure)
+ (add-action! a2 and-action-procedure)
+ 'ok)
+(define (make-wire)
+ (let ((signal-value 0) (action-procedures '()))
+ (define (set-my-signal! new-value)
+ (if (not (= signal-value new-value))
+ (begin (set! signal-value new-value)
+ (call-each action-procedures))
+ 'done))
+ (define (accept-action-procedure! proc)
+ (set! action-procedures (cons proc action-procedures))
+ (proc))
+ (define (dispatch m)
+ (cond ((eq? m 'get-signal) signal-value)
+ ((eq? m 'set-signal!) set-my-signal!)
+ ((eq? m 'add-action!) accept-action-procedure!)
+ (else (error "Unknown operation -- WIRE" m))))
+ dispatch))
+(define (call-each procedures)
+ (if (null? procedures)
+ 'done
+ (begin
+ ((car procedures))
+ (call-each (cdr procedures)))))
+(define (get-signal wire)
+ (wire 'get-signal))
+(define (set-signal! wire new-value)
+ ((wire 'set-signal!) new-value))
+(define (add-action! wire action-procedure)
+ ((wire 'add-action!) action-procedure))
+(define (after-delay delay action)
+ (add-to-agenda! (+ delay (current-time the-agenda))
+ action
+ the-agenda))
+(define (propagate)
+ (if (empty-agenda? the-agenda)
+ 'done
+ (let ((first-item (first-agenda-item the-agenda)))
+ (first-item)
+ (remove-first-agenda-item! the-agenda)
+ (propagate))))
+(define (probe name wire)
+ (add-action! wire
+ (lambda ()
+ (newline)
+ (display name)
+ (display " ")
+ (display (current-time the-agenda))
+ (display " New-value = ")
+ (display (get-signal wire)))))
+(define inverter-delay 2)
+(define and-gate-delay 3)
+(define or-gate-delay 5)
+(define input-1 (make-wire))
+(define input-2 (make-wire))
+(define sum (make-wire))
+(define carry (make-wire))
+(define (make-time-segment time queue)
+ (cons time queue))
+(define (segment-time s) (car s))
+(define (segment-queue s) (cdr s))
+(define (make-agenda) (list 0))
+(define the-agenda (make-agenda))
+(define (current-time agenda) (car agenda))
+(define (set-current-time! agenda time)
+ (set-car! agenda time))
+(define (segments agenda) (cdr agenda))
+(define (set-segments! agenda segments)
+ (set-cdr! agenda segments))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segments agenda)))
+(define (empty-agenda? agenda)
+ (null? (segments agenda)))
+(define (add-to-agenda! time action agenda)
+ (define (belongs-before? segments)
+ (or (null? segments)
+ (< time (segment-time (car segments)))))
+ (define (make-new-time-segment time action)
+ (let ((q (make-queue)))
+ (insert-queue! q action)
+ (make-time-segment time q)))
+ (define (add-to-segments! segments)
+ (if (= (segment-time (car segments)) time)
+ (insert-queue! (segment-queue (car segments))
+ action)
+ (let ((rest (cdr segments)))
+ (if (belongs-before? rest)
+ (set-cdr!
+ segments
+ (cons (make-new-time-segment time action)
+ (cdr segments)))
+ (add-to-segments! rest)))))
+ (let ((segments (segments agenda)))
+ (if (belongs-before? segments)
+ (set-segments!
+ agenda
+ (cons (make-new-time-segment time action)
+ segments))
+ (add-to-segments! segments))))
+(define (remove-first-agenda-item! agenda)
+ (let ((q (segment-queue (first-segment agenda))))
+ (delete-queue! q)
+ (if (empty-queue? q)
+ (set-segments! agenda (rest-segments agenda)))))
+(define (first-agenda-item agenda)
+ (if (empty-agenda? agenda)
+ (error "Agenda is empty -- FIRST-AGENDA-ITEM")
+ (let ((first-seg (first-segment agenda)))
+ (set-current-time! agenda (segment-time first-seg))
+ (front-queue (segment-queue first-seg)))))
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (make-queue) (cons '() '()))(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+
+;; (define (or-gate a1 a2 output)
+;; (define (logical-or x y)
+;; (if (or (= x 1) (= y 1))
+;; 1
+;; 0))
+;; (define (or-action-procedure)
+;; (let ((new-value (logical-or (get-signal a1) (get-signal a2))))
+;; (after-delay or-gate-delay
+;; (lambda ()
+;; (set-signal! output new-value)))))
+;; (add-action! a1 or-action-procedure)
+;; (add-action! a2 or-action-procedure)
+;; 'ok)
+
+;; Exercise 3.29. Another way to construct an or-gate is as a compound digital logic device, built from and-gates and inverters. Define a procedure or-gate that accomplishes this. What is the delay time of the or-gate in terms of and-gate-delay and inverter-delay?
+
+(define (or-gate a1 a2 output)
+ (let ((b1 (make-wire))
+ (b2 (make-wire))
+ (c (make-wire)))
+ (set-signal! b1 1)
+ (set-signal! b2 1)
+ (set-signal! c 1)
+ (inverter a1 b1)
+ (inverter a2 b2)
+ (and-gate b1 b2 c)
+ (inverter c output)))
+
+(define in-wire1 (make-wire))
+(define in-wire2 (make-wire))
+(define out-wire (make-wire))
+(probe 'in-wire1 in-wire1)
+(probe 'in-wire2 in-wire2)
+(probe 'out-wire out-wire)
+(or-gate in-wire1 in-wire2 out-wire)
+(propagate)
+(set-signal! in-wire1 1)
+(propagate)
+(set-signal! in-wire2 1)
+(propagate)
+(set-signal! in-wire1 0)
+(propagate)
+(set-signal! in-wire2 0)
+(propagate)
+
+;; the delay is roughly 2*inverter-delay + 1 and-gate-delay
+
blob - /dev/null
blob + 09c911424f83c99d92aba581679ba2fa03923727 (mode 644)
--- /dev/null
+++ ex3-31.scm
+(define (half-adder a b s c)
+ (let ((d (make-wire)) (e (make-wire)))
+ (or-gate a b d)
+ (and-gate a b c)
+ (inverter c e)
+ (and-gate d e s)
+ 'ok))
+(define (full-adder a b c-in sum c-out)
+ (let ((s (make-wire))
+ (c1 (make-wire))
+ (c2 (make-wire)))
+ (half-adder b c-in s c1)
+ (half-adder a s sum c2)
+ (or-gate c1 c2 c-out)
+ 'ok))
+(define (inverter input output)
+ (define (invert-input)
+ (let ((new-value (logical-not (get-signal input))))
+ (after-delay inverter-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! input invert-input)
+ 'ok)
+(define (logical-not s)
+ (cond ((= s 0) 1)
+ ((= s 1) 0)
+ (else (error "Invalid signal" s))))
+
+(define (and-gate a1 a2 output)
+ (define (logical-and x y)
+ (* x y))
+ (define (and-action-procedure)
+ (let ((new-value
+ (logical-and (get-signal a1) (get-signal a2))))
+ (after-delay and-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 and-action-procedure)
+ (add-action! a2 and-action-procedure)
+ 'ok)
+(define (make-wire)
+ (let ((signal-value 0) (action-procedures '()))
+ (define (set-my-signal! new-value)
+ (if (not (= signal-value new-value))
+ (begin (set! signal-value new-value)
+ (call-each action-procedures))
+ 'done))
+ (define (accept-action-procedure! proc)
+ (set! action-procedures (cons proc action-procedures))
+ (proc))
+ (define (dispatch m)
+ (cond ((eq? m 'get-signal) signal-value)
+ ((eq? m 'set-signal!) set-my-signal!)
+ ((eq? m 'add-action!) accept-action-procedure!)
+ (else (error "Unknown operation -- WIRE" m))))
+ dispatch))
+(define (call-each procedures)
+ (if (null? procedures)
+ 'done
+ (begin
+ ((car procedures))
+ (call-each (cdr procedures)))))
+(define (get-signal wire)
+ (wire 'get-signal))
+(define (set-signal! wire new-value)
+ ((wire 'set-signal!) new-value))
+(define (add-action! wire action-procedure)
+ ((wire 'add-action!) action-procedure))
+(define (after-delay delay action)
+ (add-to-agenda! (+ delay (current-time the-agenda))
+ action
+ the-agenda))
+(define (propagate)
+ (if (empty-agenda? the-agenda)
+ 'done
+ (let ((first-item (first-agenda-item the-agenda)))
+ (first-item)
+ (remove-first-agenda-item! the-agenda)
+ (propagate))))
+(define (probe name wire)
+ (add-action! wire
+ (lambda ()
+ (newline)
+ (display name)
+ (display " ")
+ (display (current-time the-agenda))
+ (display " New-value = ")
+ (display (get-signal wire)))))
+(define inverter-delay 2)
+(define and-gate-delay 3)
+(define or-gate-delay 5)
+(define input-1 (make-wire))
+(define input-2 (make-wire))
+(define sum (make-wire))
+(define carry (make-wire))
+(define (make-time-segment time queue)
+ (cons time queue))
+(define (segment-time s) (car s))
+(define (segment-queue s) (cdr s))
+(define (make-agenda) (list 0))
+(define the-agenda (make-agenda))
+(define (current-time agenda) (car agenda))
+(define (set-current-time! agenda time)
+ (set-car! agenda time))
+(define (segments agenda) (cdr agenda))
+(define (set-segments! agenda segments)
+ (set-cdr! agenda segments))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segments agenda)))
+(define (empty-agenda? agenda)
+ (null? (segments agenda)))
+(define (add-to-agenda! time action agenda)
+ (define (belongs-before? segments)
+ (or (null? segments)
+ (< time (segment-time (car segments)))))
+ (define (make-new-time-segment time action)
+ (let ((q (make-queue)))
+ (insert-queue! q action)
+ (make-time-segment time q)))
+ (define (add-to-segments! segments)
+ (if (= (segment-time (car segments)) time)
+ (insert-queue! (segment-queue (car segments))
+ action)
+ (let ((rest (cdr segments)))
+ (if (belongs-before? rest)
+ (set-cdr!
+ segments
+ (cons (make-new-time-segment time action)
+ (cdr segments)))
+ (add-to-segments! rest)))))
+ (let ((segments (segments agenda)))
+ (if (belongs-before? segments)
+ (set-segments!
+ agenda
+ (cons (make-new-time-segment time action)
+ segments))
+ (add-to-segments! segments))))
+(define (remove-first-agenda-item! agenda)
+ (let ((q (segment-queue (first-segment agenda))))
+ (delete-queue! q)
+ (if (empty-queue? q)
+ (set-segments! agenda (rest-segments agenda)))))
+(define (first-agenda-item agenda)
+ (if (empty-agenda? agenda)
+ (error "Agenda is empty -- FIRST-AGENDA-ITEM")
+ (let ((first-seg (first-segment agenda)))
+ (set-current-time! agenda (segment-time first-seg))
+ (front-queue (segment-queue first-seg)))))
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (make-queue) (cons '() '()))(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+(define (or-gate a1 a2 output)
+ (define (logical-or x y)
+ (if (or (= x 1) (= y 1))
+ 1
+ 0))
+ (define (or-action-procedure)
+ (let ((new-value (logical-or (get-signal a1) (get-signal a2))))
+ (after-delay or-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 or-action-procedure)
+ (add-action! a2 or-action-procedure)
+ 'ok)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 3.31. The internal procedure accept-action-procedure! defined in make-wire specifies that when a new action procedure is added to a wire, the procedure is immediately run. Explain why this initialization is necessary. In particular, trace through the half-adder example in the paragraphs above and say how the system's response would differ if we had defined accept-action-procedure! as
+
+(define (accept-action-procedure! proc)
+ (set! action-procedures (cons proc action-procedures)))
+
+;; In that case, the initial state of the system may not be consistent. For example, suppose we had:
+
+(define in-wire (make-wire))
+(define out-wire (make-wire))
+(inverter in-wire out-wire)
+
+;; out-wire should be set to 1 but it won't be until in-wire has its value changed, at which point the signal will finally propagate
blob - /dev/null
blob + 957602e62dbd7b17e18c975a30a18c23ed92a2ea (mode 644)
--- /dev/null
+++ ex3-31.scm~
+;; Exercise 3.28. Define an or-gate as a primitive function box. Your or-gate constructor should be similar to and-gate.
+
+(define (half-adder a b s c)
+ (let ((d (make-wire)) (e (make-wire)))
+ (or-gate a b d)
+ (and-gate a b c)
+ (inverter c e)
+ (and-gate d e s)
+ 'ok))
+(define (full-adder a b c-in sum c-out)
+ (let ((s (make-wire))
+ (c1 (make-wire))
+ (c2 (make-wire)))
+ (half-adder b c-in s c1)
+ (half-adder a s sum c2)
+ (or-gate c1 c2 c-out)
+ 'ok))
+(define (inverter input output)
+ (define (invert-input)
+ (let ((new-value (logical-not (get-signal input))))
+ (after-delay inverter-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! input invert-input)
+ 'ok)
+(define (logical-not s)
+ (cond ((= s 0) 1)
+ ((= s 1) 0)
+ (else (error "Invalid signal" s))))
+
+(define (and-gate a1 a2 output)
+ (define (logical-and x y)
+ (* x y))
+ (define (and-action-procedure)
+ (let ((new-value
+ (logical-and (get-signal a1) (get-signal a2))))
+ (after-delay and-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 and-action-procedure)
+ (add-action! a2 and-action-procedure)
+ 'ok)
+(define (make-wire)
+ (let ((signal-value 0) (action-procedures '()))
+ (define (set-my-signal! new-value)
+ (if (not (= signal-value new-value))
+ (begin (set! signal-value new-value)
+ (call-each action-procedures))
+ 'done))
+ (define (accept-action-procedure! proc)
+ (set! action-procedures (cons proc action-procedures))
+ (proc))
+ (define (dispatch m)
+ (cond ((eq? m 'get-signal) signal-value)
+ ((eq? m 'set-signal!) set-my-signal!)
+ ((eq? m 'add-action!) accept-action-procedure!)
+ (else (error "Unknown operation -- WIRE" m))))
+ dispatch))
+(define (call-each procedures)
+ (if (null? procedures)
+ 'done
+ (begin
+ ((car procedures))
+ (call-each (cdr procedures)))))
+(define (get-signal wire)
+ (wire 'get-signal))
+(define (set-signal! wire new-value)
+ ((wire 'set-signal!) new-value))
+(define (add-action! wire action-procedure)
+ ((wire 'add-action!) action-procedure))
+(define (after-delay delay action)
+ (add-to-agenda! (+ delay (current-time the-agenda))
+ action
+ the-agenda))
+(define (propagate)
+ (if (empty-agenda? the-agenda)
+ 'done
+ (let ((first-item (first-agenda-item the-agenda)))
+ (first-item)
+ (remove-first-agenda-item! the-agenda)
+ (propagate))))
+(define (probe name wire)
+ (add-action! wire
+ (lambda ()
+ (newline)
+ (display name)
+ (display " ")
+ (display (current-time the-agenda))
+ (display " New-value = ")
+ (display (get-signal wire)))))
+(define inverter-delay 2)
+(define and-gate-delay 3)
+(define or-gate-delay 5)
+(define input-1 (make-wire))
+(define input-2 (make-wire))
+(define sum (make-wire))
+(define carry (make-wire))
+(define (make-time-segment time queue)
+ (cons time queue))
+(define (segment-time s) (car s))
+(define (segment-queue s) (cdr s))
+(define (make-agenda) (list 0))
+(define the-agenda (make-agenda))
+(define (current-time agenda) (car agenda))
+(define (set-current-time! agenda time)
+ (set-car! agenda time))
+(define (segments agenda) (cdr agenda))
+(define (set-segments! agenda segments)
+ (set-cdr! agenda segments))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segments agenda)))
+(define (empty-agenda? agenda)
+ (null? (segments agenda)))
+(define (add-to-agenda! time action agenda)
+ (define (belongs-before? segments)
+ (or (null? segments)
+ (< time (segment-time (car segments)))))
+ (define (make-new-time-segment time action)
+ (let ((q (make-queue)))
+ (insert-queue! q action)
+ (make-time-segment time q)))
+ (define (add-to-segments! segments)
+ (if (= (segment-time (car segments)) time)
+ (insert-queue! (segment-queue (car segments))
+ action)
+ (let ((rest (cdr segments)))
+ (if (belongs-before? rest)
+ (set-cdr!
+ segments
+ (cons (make-new-time-segment time action)
+ (cdr segments)))
+ (add-to-segments! rest)))))
+ (let ((segments (segments agenda)))
+ (if (belongs-before? segments)
+ (set-segments!
+ agenda
+ (cons (make-new-time-segment time action)
+ segments))
+ (add-to-segments! segments))))
+(define (remove-first-agenda-item! agenda)
+ (let ((q (segment-queue (first-segment agenda))))
+ (delete-queue! q)
+ (if (empty-queue? q)
+ (set-segments! agenda (rest-segments agenda)))))
+(define (first-agenda-item agenda)
+ (if (empty-agenda? agenda)
+ (error "Agenda is empty -- FIRST-AGENDA-ITEM")
+ (let ((first-seg (first-segment agenda)))
+ (set-current-time! agenda (segment-time first-seg))
+ (front-queue (segment-queue first-seg)))))
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (make-queue) (cons '() '()))(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+(define (or-gate a1 a2 output)
+ (define (logical-or x y)
+ (if (or (= x 1) (= y 1))
+ 1
+ 0))
+ (define (or-action-procedure)
+ (let ((new-value (logical-or (get-signal a1) (get-signal a2))))
+ (after-delay or-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 or-action-procedure)
+ (add-action! a2 or-action-procedure)
+ 'ok)
+
+;; the delay is roughly 2*inverter-delay + 1 and-gate-delay
+
+;; Exercise 3.30. Figure 3.27 shows a ripple-carry adder formed by stringing together n full-adders. This is the simplest form of parallel adder for adding two n-bit binary numbers. The inputs A1, A2, A3, ..., An and B1, B2, B3, ..., Bn are the two binary numbers to be added (each Ak and Bk is a 0 or a 1). The circuit generates S1, S2, S3, ..., Sn, the n bits of the sum, and C, the carry from the addition. Write a procedure ripple-carry-adder that generates this circuit. The procedure should take as arguments three lists of n wires each -- the Ak, the Bk, and the Sk -- and also another wire C. The major drawback of the ripple-carry adder is the need to wait for the carry signals to propagate. What is the delay needed to obtain the complete output from an n-bit ripple-carry adder, expressed in terms of the delays for and-gates, or-gates, and inverters?
+
+(define (ripple-carry-adder a b s c)
+ (if (null? a)
+ 'done
+ (let ((ak (car a))
+ (bk (car b))
+ (sk (car s))
+ (ck (make-wire)))
+ (full-adder ak bk ck sk c)
+ (ripple-carry-adder (cdr a) (cdr b) (cdr s) ck))))
+
+;; returns list of wires with digits
+(define (make-digits digits)
+ (if (null? digits)
+ '()
+ (let ((digit (car digits))
+ (wire (make-wire)))
+ (set-signal! wire digit)
+ (cons wire (make-digits (cdr digits))))))
+
+(define one-three-six (make-digits '(1 0 0 0 1 0 0 0)))
+(define seven-five (make-digits '(0 1 0 0 1 0 1 1)))
+(define sum1 (make-digits '(0 0 0 0 0 0 0 0)))
+(define carry1 (make-wire))
+(ripple-carry-adder one-three-six
+ seven-five
+ sum1
+ carry1)
+(propagate)
+(define two-three-seven (make-digits '(1 1 1 0 1 1 0 1)))
+(define one-nine-eight (make-digits '(1 1 0 0 0 1 1 0)))
+(define sum2 (make-digits '(0 0 0 0 0 0 0 0)))
+(define carry2 (make-wire))
+
+(ripple-carry-adder two-three-seven
+ one-nine-eight
+ sum2
+ carry2)
+(propagate)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(test-case (map get-signal one-three-six) '(1 0 0 0 1 0 0 0))
+(test-case (map get-signal seven-five) '(0 1 0 0 1 0 1 1))
+(test-case (map get-signal sum1) '(1 1 0 1 0 0 1 1))
+(test-case (get-signal carry1) 0)
+
+(test-case (map get-signal two-three-seven) '(1 1 1 0 1 1 0 1))
+(test-case (map get-signal one-nine-eight) '(1 1 0 0 0 1 1 0))
+(test-case (map get-signal sum2) '(1 0 1 1 0 0 1 1))
+(test-case (get-signal carry2) 1)
+
+(define carry3 (make-wire))
+(ripple-carry-adder '() '() '() carry3)
+(test-case (get-signal carry3) 0)
blob - /dev/null
blob + 45177f64ef3aad5943c700ec3330a0d68c46e454 (mode 644)
--- /dev/null
+++ ex3-32.scm
+(define (half-adder a b s c)
+ (let ((d (make-wire)) (e (make-wire)))
+ (or-gate a b d)
+ (and-gate a b c)
+ (inverter c e)
+ (and-gate d e s)
+ 'ok))
+(define (full-adder a b c-in sum c-out)
+ (let ((s (make-wire))
+ (c1 (make-wire))
+ (c2 (make-wire)))
+ (half-adder b c-in s c1)
+ (half-adder a s sum c2)
+ (or-gate c1 c2 c-out)
+ 'ok))
+(define (inverter input output)
+ (define (invert-input)
+ (let ((new-value (logical-not (get-signal input))))
+ (after-delay inverter-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! input invert-input)
+ 'ok)
+(define (logical-not s)
+ (cond ((= s 0) 1)
+ ((= s 1) 0)
+ (else (error "Invalid signal" s))))
+
+(define (and-gate a1 a2 output)
+ (define (logical-and x y)
+ (* x y))
+ (define (and-action-procedure)
+ (let ((new-value
+ (logical-and (get-signal a1) (get-signal a2))))
+ (after-delay and-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 and-action-procedure)
+ (add-action! a2 and-action-procedure)
+ 'ok)
+(define (make-wire)
+ (let ((signal-value 0) (action-procedures '()))
+ (define (set-my-signal! new-value)
+ (if (not (= signal-value new-value))
+ (begin (set! signal-value new-value)
+ (call-each action-procedures))
+ 'done))
+ (define (accept-action-procedure! proc)
+ (set! action-procedures (cons proc action-procedures))
+ (proc))
+ (define (dispatch m)
+ (cond ((eq? m 'get-signal) signal-value)
+ ((eq? m 'set-signal!) set-my-signal!)
+ ((eq? m 'add-action!) accept-action-procedure!)
+ (else (error "Unknown operation -- WIRE" m))))
+ dispatch))
+(define (call-each procedures)
+ (if (null? procedures)
+ 'done
+ (begin
+ ((car procedures))
+ (call-each (cdr procedures)))))
+(define (get-signal wire)
+ (wire 'get-signal))
+(define (set-signal! wire new-value)
+ ((wire 'set-signal!) new-value))
+(define (add-action! wire action-procedure)
+ ((wire 'add-action!) action-procedure))
+(define (after-delay delay action)
+ (add-to-agenda! (+ delay (current-time the-agenda))
+ action
+ the-agenda))
+(define (propagate)
+ (if (empty-agenda? the-agenda)
+ 'done
+ (let ((first-item (first-agenda-item the-agenda)))
+ (first-item)
+ (remove-first-agenda-item! the-agenda)
+ (propagate))))
+(define (probe name wire)
+ (add-action! wire
+ (lambda ()
+ (newline)
+ (display name)
+ (display " ")
+ (display (current-time the-agenda))
+ (display " New-value = ")
+ (display (get-signal wire)))))
+(define inverter-delay 2)
+(define and-gate-delay 3)
+(define or-gate-delay 5)
+(define input-1 (make-wire))
+(define input-2 (make-wire))
+(define sum (make-wire))
+(define carry (make-wire))
+(define (make-time-segment time queue)
+ (cons time queue))
+(define (segment-time s) (car s))
+(define (segment-queue s) (cdr s))
+(define (make-agenda) (list 0))
+(define the-agenda (make-agenda))
+(define (current-time agenda) (car agenda))
+(define (set-current-time! agenda time)
+ (set-car! agenda time))
+(define (segments agenda) (cdr agenda))
+(define (set-segments! agenda segments)
+ (set-cdr! agenda segments))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segments agenda)))
+(define (empty-agenda? agenda)
+ (null? (segments agenda)))
+(define (add-to-agenda! time action agenda)
+ (define (belongs-before? segments)
+ (or (null? segments)
+ (< time (segment-time (car segments)))))
+ (define (make-new-time-segment time action)
+ (let ((q (make-queue)))
+ (insert-queue! q action)
+ (make-time-segment time q)))
+ (define (add-to-segments! segments)
+ (if (= (segment-time (car segments)) time)
+ (insert-queue! (segment-queue (car segments))
+ action)
+ (let ((rest (cdr segments)))
+ (if (belongs-before? rest)
+ (set-cdr!
+ segments
+ (cons (make-new-time-segment time action)
+ (cdr segments)))
+ (add-to-segments! rest)))))
+ (let ((segments (segments agenda)))
+ (if (belongs-before? segments)
+ (set-segments!
+ agenda
+ (cons (make-new-time-segment time action)
+ segments))
+ (add-to-segments! segments))))
+(define (remove-first-agenda-item! agenda)
+ (let ((q (segment-queue (first-segment agenda))))
+ (delete-queue! q)
+ (if (empty-queue? q)
+ (set-segments! agenda (rest-segments agenda)))))
+(define (first-agenda-item agenda)
+ (if (empty-agenda? agenda)
+ (error "Agenda is empty -- FIRST-AGENDA-ITEM")
+ (let ((first-seg (first-segment agenda)))
+ (set-current-time! agenda (segment-time first-seg))
+ (front-queue (segment-queue first-seg)))))
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (make-queue) (cons '() '()))(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+(define (or-gate a1 a2 output)
+ (define (logical-or x y)
+ (if (or (= x 1) (= y 1))
+ 1
+ 0))
+ (define (or-action-procedure)
+ (let ((new-value (logical-or (get-signal a1) (get-signal a2))))
+ (after-delay or-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 or-action-procedure)
+ (add-action! a2 or-action-procedure)
+ 'ok)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 3.32. The procedures to be run during each time segment of the agenda are kept in a queue. Thus, the procedures for each segment are called in the order in which they were added to the agenda (first in, first out). Explain why this order must be used. In particular, trace the behavior of an and-gate whose inputs change from 0,1 to 1,0 in the same segment and say how the behavior would differ if we stored a segment's procedures in an ordinary list, adding and removing procedures only at the front (last in, first out).
+
+;; When the input is changed from (0, 1) to (1, 1), the output wire will be set to 1. When the inputs are then changed from (1, 1) to (1, 0), the output wire will be set to 0. However, if we do not use FIFO for the agenda, then the output wire will first be set to 0, then 1, leaving our circuit in an inconsistent state.
blob - /dev/null
blob + 09c911424f83c99d92aba581679ba2fa03923727 (mode 644)
--- /dev/null
+++ ex3-32.scm~
+(define (half-adder a b s c)
+ (let ((d (make-wire)) (e (make-wire)))
+ (or-gate a b d)
+ (and-gate a b c)
+ (inverter c e)
+ (and-gate d e s)
+ 'ok))
+(define (full-adder a b c-in sum c-out)
+ (let ((s (make-wire))
+ (c1 (make-wire))
+ (c2 (make-wire)))
+ (half-adder b c-in s c1)
+ (half-adder a s sum c2)
+ (or-gate c1 c2 c-out)
+ 'ok))
+(define (inverter input output)
+ (define (invert-input)
+ (let ((new-value (logical-not (get-signal input))))
+ (after-delay inverter-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! input invert-input)
+ 'ok)
+(define (logical-not s)
+ (cond ((= s 0) 1)
+ ((= s 1) 0)
+ (else (error "Invalid signal" s))))
+
+(define (and-gate a1 a2 output)
+ (define (logical-and x y)
+ (* x y))
+ (define (and-action-procedure)
+ (let ((new-value
+ (logical-and (get-signal a1) (get-signal a2))))
+ (after-delay and-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 and-action-procedure)
+ (add-action! a2 and-action-procedure)
+ 'ok)
+(define (make-wire)
+ (let ((signal-value 0) (action-procedures '()))
+ (define (set-my-signal! new-value)
+ (if (not (= signal-value new-value))
+ (begin (set! signal-value new-value)
+ (call-each action-procedures))
+ 'done))
+ (define (accept-action-procedure! proc)
+ (set! action-procedures (cons proc action-procedures))
+ (proc))
+ (define (dispatch m)
+ (cond ((eq? m 'get-signal) signal-value)
+ ((eq? m 'set-signal!) set-my-signal!)
+ ((eq? m 'add-action!) accept-action-procedure!)
+ (else (error "Unknown operation -- WIRE" m))))
+ dispatch))
+(define (call-each procedures)
+ (if (null? procedures)
+ 'done
+ (begin
+ ((car procedures))
+ (call-each (cdr procedures)))))
+(define (get-signal wire)
+ (wire 'get-signal))
+(define (set-signal! wire new-value)
+ ((wire 'set-signal!) new-value))
+(define (add-action! wire action-procedure)
+ ((wire 'add-action!) action-procedure))
+(define (after-delay delay action)
+ (add-to-agenda! (+ delay (current-time the-agenda))
+ action
+ the-agenda))
+(define (propagate)
+ (if (empty-agenda? the-agenda)
+ 'done
+ (let ((first-item (first-agenda-item the-agenda)))
+ (first-item)
+ (remove-first-agenda-item! the-agenda)
+ (propagate))))
+(define (probe name wire)
+ (add-action! wire
+ (lambda ()
+ (newline)
+ (display name)
+ (display " ")
+ (display (current-time the-agenda))
+ (display " New-value = ")
+ (display (get-signal wire)))))
+(define inverter-delay 2)
+(define and-gate-delay 3)
+(define or-gate-delay 5)
+(define input-1 (make-wire))
+(define input-2 (make-wire))
+(define sum (make-wire))
+(define carry (make-wire))
+(define (make-time-segment time queue)
+ (cons time queue))
+(define (segment-time s) (car s))
+(define (segment-queue s) (cdr s))
+(define (make-agenda) (list 0))
+(define the-agenda (make-agenda))
+(define (current-time agenda) (car agenda))
+(define (set-current-time! agenda time)
+ (set-car! agenda time))
+(define (segments agenda) (cdr agenda))
+(define (set-segments! agenda segments)
+ (set-cdr! agenda segments))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segments agenda)))
+(define (empty-agenda? agenda)
+ (null? (segments agenda)))
+(define (add-to-agenda! time action agenda)
+ (define (belongs-before? segments)
+ (or (null? segments)
+ (< time (segment-time (car segments)))))
+ (define (make-new-time-segment time action)
+ (let ((q (make-queue)))
+ (insert-queue! q action)
+ (make-time-segment time q)))
+ (define (add-to-segments! segments)
+ (if (= (segment-time (car segments)) time)
+ (insert-queue! (segment-queue (car segments))
+ action)
+ (let ((rest (cdr segments)))
+ (if (belongs-before? rest)
+ (set-cdr!
+ segments
+ (cons (make-new-time-segment time action)
+ (cdr segments)))
+ (add-to-segments! rest)))))
+ (let ((segments (segments agenda)))
+ (if (belongs-before? segments)
+ (set-segments!
+ agenda
+ (cons (make-new-time-segment time action)
+ segments))
+ (add-to-segments! segments))))
+(define (remove-first-agenda-item! agenda)
+ (let ((q (segment-queue (first-segment agenda))))
+ (delete-queue! q)
+ (if (empty-queue? q)
+ (set-segments! agenda (rest-segments agenda)))))
+(define (first-agenda-item agenda)
+ (if (empty-agenda? agenda)
+ (error "Agenda is empty -- FIRST-AGENDA-ITEM")
+ (let ((first-seg (first-segment agenda)))
+ (set-current-time! agenda (segment-time first-seg))
+ (front-queue (segment-queue first-seg)))))
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+(define (empty-queue? queue) (null? (front-ptr queue)))
+(define (make-queue) (cons '() '()))(define (front-queue queue)
+ (if (empty-queue? queue)
+ (error "FRONT called with an empty queue" queue)
+ (car (front-ptr queue))))
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (error "DELETE! called with an empty queue" queue))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+(define (or-gate a1 a2 output)
+ (define (logical-or x y)
+ (if (or (= x 1) (= y 1))
+ 1
+ 0))
+ (define (or-action-procedure)
+ (let ((new-value (logical-or (get-signal a1) (get-signal a2))))
+ (after-delay or-gate-delay
+ (lambda ()
+ (set-signal! output new-value)))))
+ (add-action! a1 or-action-procedure)
+ (add-action! a2 or-action-procedure)
+ 'ok)
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 3.31. The internal procedure accept-action-procedure! defined in make-wire specifies that when a new action procedure is added to a wire, the procedure is immediately run. Explain why this initialization is necessary. In particular, trace through the half-adder example in the paragraphs above and say how the system's response would differ if we had defined accept-action-procedure! as
+
+(define (accept-action-procedure! proc)
+ (set! action-procedures (cons proc action-procedures)))
+
+;; In that case, the initial state of the system may not be consistent. For example, suppose we had:
+
+(define in-wire (make-wire))
+(define out-wire (make-wire))
+(inverter in-wire out-wire)
+
+;; out-wire should be set to 1 but it won't be until in-wire has its value changed, at which point the signal will finally propagate
blob - /dev/null
blob + 177f6580b89a4913598bc824da9b0d18711864f8 (mode 644)
--- /dev/null
+++ ex3-33-scratch.scm
+(define C (make-connector))
+(define F (make-connector))
+(celsius-fahrenheit-converter C F)
+
+(define (celsius-fahrenheit-converter c f)
+ (let ((u (make-connector))
+ (v (make-connector))
+ (w (make-connector))
+ (x (make-connector))
+ (y (make-connector)))
+ (multiplier c w u)
+ (multiplier v x u)
+ (adder v y f)
+ (constant 9 w)
+ (constant 5 x)
+ (constant 32 y)
+ 'ok))
+
+(has-value? <connector>)
+(get-value <connector>)
+(set-value! <connector> <new-value> <informant>)
+(forget-value! <connector> <retractor>)
+(connect <connector> <new-constraint>)
+
+(define (adder a1 a2 sum)
+ (define (process-new-value)
+ (cond ((and (has-value? a1) (has-value? a2))
+ (set-value! sum
+ (+ (get-value a1) (get-value a2))
+ me))
+ ((and (has-value? a1) (has-value? sum))
+ (set-value! a2
+ (- (get-value sum) (get-value a1))
+ me))
+ ((and (has-value? a2) (has-value? sum))
+ (set-value! a1
+ (- (get-value sum) (get-value a2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! sum me)
+ (forget-value! a1 me)
+ (forget-value! a2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- ADDER" request))))
+ (connect a1 me)
+ (connect a2 me)
+ (connect sum me)
+ me)
+
+(define (inform-about-value constraint)
+ (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+ (constraint 'I-lost-my-value))
+
+(define (multiplier m1 m2 product)
+ (define (process-new-value)
+ (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+ (and (has-value? m2) (= (get-value m2) 0)))
+ (set-value! product 0 me))
+ ((and (has-value? m1) (has-value? m2))
+ (set-value! product
+ (* (get-value m1) (get-value m2))
+ me))
+ ((and (has-value? product) (has-value? m1))
+ (set-value! m2
+ (/ (get-value product) (get-value m1))
+ me))
+ ((and (has-value? product) (has-value? m2))
+ (set-value! m1
+ (/ (get-value product) (get-value m2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! product me)
+ (forget-value! m1 me)
+ (forget-value! m2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- MULTIPLIER" request))))
+ (connect m1 me)
+ (connect m2 me)
+ (connect product me)
+ me)
+
+(define (constant value connector)
+ (define (me request)
+ (error "Unknown request -- CONSTANT" request))
+ (connect connector me)
+ (set-value! connector value me)
+ me)
+
+(define (probe name connector)
+ (define (print-probe value)
+ (newline)
+ (display "Probe: ")
+ (display name)
+ (display " = ")
+ (display value))
+ (define (process-new-value)
+ (print-probe (get-value connector)))
+ (define (process-forget-value)
+ (print-probe "?"))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- PROBE" request))))
+ (connect connector me)
+ me)
+
+(define (make-connector)
+ (let ((value false) (informant false) (constraints '()))
+ (define (set-my-value newval setter)
+ (cond ((not (has-value? me))
+ (set! value newval)
+ (set! informant setter)
+ (for-each-except setter
+ inform-about-value
+ constraints))
+ ((not (= value newval))
+ (error "Contradiction" (list value newval)))
+ (else 'ignored)))
+ (define (forget-my-value retractor)
+ (if (eq? retractor informant)
+ (begin (set! informant false)
+ (for-each-except retractor
+ inform-about-no-value
+ constraints))
+ 'ignored))
+ (define (connect new-constraint)
+ (if (not (memq new-constraint constraints))
+ (set! constraints
+ (cons new-constraint constraints)))
+ (if (has-value? me)
+ (inform-about-value new-constraint))
+ 'done)
+ (define (me request)
+ (cond ((eq? request 'has-value?)
+ (if informant true false))
+ ((eq? request 'value) value)
+ ((eq? request 'set-value!) set-my-value)
+ ((eq? request 'forget) forget-my-value)
+ ((eq? request 'connect) connect)
+ (else (error "Unknown operation -- CONNECTOR"
+ request))))
+ me))
+
+(define (for-each-except exception procedure list)
+ (define (loop items)
+ (cond ((null? items) 'done)
+ ((eq? (car items) exception) (loop (cdr items)))
+ (else (procedure (car items))
+ (loop (cdr items)))))
+ (loop list))
+
+(define (has-value? connector)
+ (connector 'has-value?))
+(define (get-value connector)
+ (connector 'value))
+(define (set-value! connector new-value informant)
+ ((connector 'set-value!) new-value informant))
+(define (forget-value! connector retractor)
+ ((connector 'forget) retractor))
+(define (connect connector new-constraint)
+ ((connector 'connect) new-constraint))
blob - /dev/null
blob + 11c1012f0b50c4dc1e8879964db248c4d3c2c588 (mode 644)
--- /dev/null
+++ ex3-33-scratch.scm~
+(define (celsius-fahrenheit-converter c f)
+ (let ((nine (make-connector))
+ (five (make-connector))
+ (three-two (make-connector))
+ (product (make-connector))
+ (difference (make-connector)))
+ (constant 9 nine)
+ (constant 5 five)
+ (constant 32 three-two)
+ (adder three-two difference f)
+ (multiplier c nine product)
+ (multiplier five difference product))
+ 'ok)
+
+(define (adder a1 a2 sum)
+ (define (process-new-value)
+ (cond ((and (has-value? a1) (has-value? a2))
+ (set-value! sum
+ (+ (get-value a1)
+ (get-value a2))
+ me))
+ ((and (has-value? a1) (has-value? sum))
+ (set-value! a2
+ (- (get-value sum)
+ (get-value a1))
+ me))
+ ((and (has-value? a2) (has-value? sum))
+ (set-value! a1
+ (- (get-value sum)
+ (get-value a2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! a1 me)
+ (forget-value! a2 me)
+ (forget-value! sum me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? 'I-have-a-value) (process-new-value))
+ ((eq? 'I-lost-my-value) (process-forget-value))
+ (else (error "Unknown request -- ADDER" request))))
+ (connect a1 me)
+ (connect a2 me)
+ (connect sum me)
+ me)
+
+(define (inform-about-value constraint)
+ (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+ (constraint 'I-lost-my-value))
+
+(define (multiplier m1 m2 product)
+ (define (process-new-value)
+ (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+ (and (has-value? m2) (= (get-value m2) 0)))
+ (set-value! product 0 me))
+ ((and (has-value? m1) (has-value? m2))
+ (set-value! product
+ (* (get-value m1)
+ (get-value m2))
+ me))
+ ((and (has-value? m1) (has-value? product))
+ (set-value! m2
+ (/ (get-value product)
+ (get-value m1))
+ me))
+ ((and (has-value? m2) (has-value? product))
+ (set-value! m1
+ (/ (get-value product)
+ (get-value m2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! m1 me)
+ (forget-value! m2 me)
+ (forget-value! product me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value) (process-new-value))
+ ((eq? request 'I-lost-my-value) (process-forget-value))
+ (else (error "Unknown request -- MULTIPLIER" request))))
+ (connect m1 me)
+ (connect m2 me)
+ (connect product me)
+ me)
+
+(define (constant value connector)
+ (define (me request)
+ (error "Unknown request -- CONSTANT" request))
+ (connect connector me)
+ (set-value! connector value me)
+ me)
+
+(define (probe name connector)
+ (define (print-probe value)
+ (newline)
+ (display name)
+ (display ": ")
+ (display value))
+ (define (process-new-value)
+ (print-probe (get-value connector)))
+ (define (process-forget-value)
+ (print-probe "?"))
+ (define (me request)
+ (cond ((eq? 'I-have-a-value) (process-new-value))
+ ((eq? 'I-lost-my-value) (process-forget-value))
+ (else (error "Unknown request -- PROBE" request))))
+ (connect connector me)
+ me)
+
+(define (for-each-except exception proc items)
+ (cond ((null? items) 'done)
+ ((eq? (car items) exception)
+ (for-each-except exception proc (cdr items)))
+ (else (proc (car items))
+ (for-each-except exception proc (cdr items)))))
+
+(define (make-connector)
+ (let ((value false) (informant false) (constraints '()))
+ (define (set-my-value newval setter)
+ (if informant
+ (if (= value newval)
+ 'ignored
+ (error "Contradictory values: " (list value newval)))
+ (begin (set-value! informant setter)
+ (set-value! value newval)
+ (for-each-except setter
+ inform-about-value
+ constraints))))
+ (define (forget-my-value retractor)
+ (if (eq? retractor informant)
+ (begin (set-value! informant false)
+ (for-each-except retractor
+ inform-about-no-value
+ constraints))
+ 'ignored))
+ (define (connect constraint)
+ (if (memq constraint constraints)
+ 'ignored
+ (begin (set! constraints (cons constraint constraints))
+ (if (has-value? me)
+ (inform-about-value constraint)))))
+ (define (me request)
+ (cond ((eq? request 'has-value?) (if informant true false))
+ ((eq? request 'value) value)
+ ((eq? request 'set-value!) set-my-value)
+ ((eq? request 'forget) forget-my-value)
+ ((eq? request 'connect) connect)
+ (else (error "Unknown operation -- CONNECTOR" request))))
+ me))
+
+(define (has-value? connector)
+ (connector 'has-value))
+(define (get-value connector)
+ (connector 'value))
+(define (set-value! connector newval informant)
+ ((connector 'set-value!) newval informant))
+(define (forget-value! connector retractor)
+ ((connector 'forget) retractor))
+(define (connect connector constraint)
+ ((connector 'connect) constraint))
+
blob - /dev/null
blob + 38ef4e404695eda54c23cc8e7a8e51e12ab103b6 (mode 644)
--- /dev/null
+++ ex3-33.scm
+(define (celsius-fahrenheit-converter c f)
+ (let ((u (make-connector))
+ (v (make-connector))
+ (w (make-connector))
+ (x (make-connector))
+ (y (make-connector)))
+ (multiplier c w u)
+ (multiplier v x u)
+ (adder v y f)
+ (constant 9 w)
+ (constant 5 x)
+ (constant 32 y)
+ 'ok))
+
+(define (adder a1 a2 sum)
+ (define (process-new-value)
+ (cond ((and (has-value? a1) (has-value? a2))
+ (set-value! sum
+ (+ (get-value a1) (get-value a2))
+ me))
+ ((and (has-value? a1) (has-value? sum))
+ (set-value! a2
+ (- (get-value sum) (get-value a1))
+ me))
+ ((and (has-value? a2) (has-value? sum))
+ (set-value! a1
+ (- (get-value sum) (get-value a2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! sum me)
+ (forget-value! a1 me)
+ (forget-value! a2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- ADDER" request))))
+ (connect a1 me)
+ (connect a2 me)
+ (connect sum me)
+ me)
+
+(define (inform-about-value constraint)
+ (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+ (constraint 'I-lost-my-value))
+
+(define (multiplier m1 m2 product)
+ (define (process-new-value)
+ (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+ (and (has-value? m2) (= (get-value m2) 0)))
+ (set-value! product 0 me))
+ ((and (has-value? m1) (has-value? m2))
+ (set-value! product
+ (* (get-value m1) (get-value m2))
+ me))
+ ((and (has-value? product) (has-value? m1))
+ (set-value! m2
+ (/ (get-value product) (get-value m1))
+ me))
+ ((and (has-value? product) (has-value? m2))
+ (set-value! m1
+ (/ (get-value product) (get-value m2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! product me)
+ (forget-value! m1 me)
+ (forget-value! m2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- MULTIPLIER" request))))
+ (connect m1 me)
+ (connect m2 me)
+ (connect product me)
+ me)
+
+(define (constant value connector)
+ (define (me request)
+ (error "Unknown request -- CONSTANT" request))
+ (connect connector me)
+ (set-value! connector value me)
+ me)
+
+(define (probe name connector)
+ (define (print-probe value)
+ (newline)
+ (display "Probe: ")
+ (display name)
+ (display " = ")
+ (display value))
+ (define (process-new-value)
+ (print-probe (get-value connector)))
+ (define (process-forget-value)
+ (print-probe "?"))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- PROBE" request))))
+ (connect connector me)
+ me)
+
+(define (make-connector)
+ (let ((value false) (informant false) (constraints '()))
+ (define (set-my-value newval setter)
+ (cond ((not (has-value? me))
+ (set! value newval)
+ (set! informant setter)
+ (for-each-except setter
+ inform-about-value
+ constraints))
+ ((not (= value newval))
+ (error "Contradiction" (list value newval)))
+ (else 'ignored)))
+ (define (forget-my-value retractor)
+ (if (eq? retractor informant)
+ (begin (set! informant false)
+ (for-each-except retractor
+ inform-about-no-value
+ constraints))
+ 'ignored))
+ (define (connect new-constraint)
+ (if (not (memq new-constraint constraints))
+ (set! constraints
+ (cons new-constraint constraints)))
+ (if (has-value? me)
+ (inform-about-value new-constraint))
+ 'done)
+ (define (me request)
+ (cond ((eq? request 'has-value?)
+ (if informant true false))
+ ((eq? request 'value) value)
+ ((eq? request 'set-value!) set-my-value)
+ ((eq? request 'forget) forget-my-value)
+ ((eq? request 'connect) connect)
+ (else (error "Unknown operation -- CONNECTOR"
+ request))))
+ me))
+
+(define (for-each-except exception procedure list)
+ (define (loop items)
+ (cond ((null? items) 'done)
+ ((eq? (car items) exception) (loop (cdr items)))
+ (else (procedure (car items))
+ (loop (cdr items)))))
+ (loop list))
+
+(define (has-value? connector)
+ (connector 'has-value?))
+(define (get-value connector)
+ (connector 'value))
+(define (set-value! connector new-value informant)
+ ((connector 'set-value!) new-value informant))
+(define (forget-value! connector retractor)
+ ((connector 'forget) retractor))
+(define (connect connector new-constraint)
+ ((connector 'connect) new-constraint))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 3.33. Using primitive multiplier, adder, and constant constraints, define a procedure averager that takes three connectors a, b, and c as inputs and establishes the constraint that the value of c is the average of the values of a and b.
+
+(define (averager a b c)
+ (let ((sum (make-connector))
+ (two (make-connector)))
+ (adder a b sum)
+ (constant 2 two)
+ (multiplier two c sum)))
+
+(define five (make-connector))
+(define three (make-connector))
+(define avg (make-connector))
+(constant 5 five)
+(constant 3 three)
+(averager five three avg)
+(test-case (get-value avg) 4)
blob - /dev/null
blob + 36e3e90c7043a77bd43acd858b4902affe18ceaa (mode 644)
--- /dev/null
+++ ex3-33.scm~
+(define (celsius-fahrenheit-converter c f)
+ (let ((five (make-connector))
+ (nine (make-connector))
+ (three-two (make-connector))
+ (product (make-connector))
+ (difference (make-connector)))
+ (constant 9 nine)
+ (constant 5 five)
+ (constant 32 three-two)
+ (multiplier nine c product)
+ (adder difference three-two f)
+ (multiplier difference five product)
+ 'ok))
+(define (inform-about-value constraint)
+ (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+ (constraint 'I-lost-my-value))
+
+(define (adder a1 a2 sum)
+ (define (process-new-value)
+ (cond ((and (has-value? a1) (has-value? a2))
+ (set-value! sum
+ (+ (get-value a1)
+ (get-value a2))
+ me))
+ ((and (has-value? a1) (has-value? sum))
+ (set-value! a2
+ (- (get-value sum)
+ (get-value a1))
+ me))
+ ((and (has-value? a2) (has-value? sum))
+ (set-value! a1
+ (- (get-value sum)
+ (get-value a2))))))
+ (define (process-forget-value)
+ (forget-value! a1)
+ (forget-value! a2)
+ (forget-value! sum)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value) (process-new-value))
+ ((eq? request 'I-lost-my-value) (process-forget-value))
+ (else (error "Unknown request -- ADDER" request))))
+ (connect a1 me)
+ (connect a2 me)
+ (connect sum me)
+ me)
+
+(define (multiplier m1 m2 product)
+ (define (process-new-value)
+ (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+ (and (has-value? m2) (= (get-value m2) 0)))
+ (set-value! product 0 me))
+ ((and (has-value? m1) (has-value? m2))
+ (set-value! product
+ (* (get-value m1)
+ (get-value m2))
+ me))
+ ((and (has-value? m1) (has-value? product))
+ (set-value! m2
+ (/ (get-value product)
+ (get-value m1))
+ me))
+ ((and (has-value? m2) (has-value? product))
+ (set-value! m1
+ (/ (get-value product)
+ (get-value m2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! m1 me)
+ (forget-value! m2 me)
+ (forget-value! product me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value) (process-new-value))
+ ((eq? request 'I-lost-my-value) (process-forget-value))
+ (else (error "Unknown request -- MULTIPLIER" request))))
+ (connect m1 me)
+ (connect m2 me)
+ (connect product me)
+ me)
+
+(define (constant value connector)
+ (define (me request)
+ (error "Unknown request -- CONSTANT" request))
+ (set-value! connector value me)
+ me)
+(define (probe name connector)
+ (define (print-probe value)
+ (newline)
+ (display "Probe: ")
+ (display name)
+ (display " = ")
+ (display value))
+ (define (process-new-value)
+ (print-probe (get-value connector)))
+ (define (process-forget-value)
+ (print-probe "?"))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value) (process-new-value))
+ ((eq? request 'I-lost-my-value) (process-forget-value))
+ (else (error "Unknown request -- PROBE" request))))
+ (connect connector me)
+ me)
+
+(define (has-value? connector)
+ (connector 'has-value?))
+(define (get-value connector)
+ (connector 'value))
+(define (set-value! connector value informant)
+ ((connector 'set-value!) value informant))
+(define (forget-value! connector retractor)
+ ((connector 'forget-value!) retractor))
+(define (connect connector constraint)
+ ((connector 'connect) constraint))
+
+(define (for-each-except exception proc items)
+ (cond ((null? items) 'done)
+ ((eq? (car items) exception)
+ (for-each-except exception proc (cdr items)))
+ (else
+ (proc (car items))
+ (for-each-except exception proc (cdr items)))))
+
+(define (make-connector)
+ (let ((value false) (informant false) (constraints '()))
+ (define (set-value! newval setter)
+ (if informant
+ (if (= newval value)
+ 'ignored
+ (error "Contradiction: " (list value newval)))
+ (begin (set! informant setter)
+ (set! value newval)
+ (for-each-except setter
+ inform-about-value
+ constraints))))
+ (define (forget-value! retractor)
+ (if (eq? informant retractor)
+ (begin (set! informant false)
+ (for-each-except retractor
+ inform-about-no-value
+ constraints))
+ 'ignored))
+ (define (connect constraint)
+ (if (memq constraint constraints)
+ 'ignored
+ (begin (set! constraints (cons constraint constraints))
+ (if (has-value? me)
+ (inform-about-value constraint)))))
+ (define (me request)
+ (cond ((eq? request 'has-value?) (if informant true false))
+ ((eq? request 'value) value)
+ ((eq? request 'set-value!) set-value!)
+ ((eq? request 'forget-value!) forget-value!)
+ ((eq? request 'connect) connect)
+ (else (error "Unknown operation -- CONNECTOR" request))))
+ me))
+
blob - /dev/null
blob + 721b48cd4f936b6fbfc69bb9a74179fca1cd263d (mode 644)
--- /dev/null
+++ ex3-34.scm
+(define (celsius-fahrenheit-converter c f)
+ (let ((u (make-connector))
+ (v (make-connector))
+ (w (make-connector))
+ (x (make-connector))
+ (y (make-connector)))
+ (multiplier c w u)
+ (multiplier v x u)
+ (adder v y f)
+ (constant 9 w)
+ (constant 5 x)
+ (constant 32 y)
+ 'ok))
+
+(define (adder a1 a2 sum)
+ (define (process-new-value)
+ (cond ((and (has-value? a1) (has-value? a2))
+ (set-value! sum
+ (+ (get-value a1) (get-value a2))
+ me))
+ ((and (has-value? a1) (has-value? sum))
+ (set-value! a2
+ (- (get-value sum) (get-value a1))
+ me))
+ ((and (has-value? a2) (has-value? sum))
+ (set-value! a1
+ (- (get-value sum) (get-value a2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! sum me)
+ (forget-value! a1 me)
+ (forget-value! a2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- ADDER" request))))
+ (connect a1 me)
+ (connect a2 me)
+ (connect sum me)
+ me)
+
+(define (inform-about-value constraint)
+ (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+ (constraint 'I-lost-my-value))
+
+(define (multiplier m1 m2 product)
+ (define (process-new-value)
+ (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+ (and (has-value? m2) (= (get-value m2) 0)))
+ (set-value! product 0 me))
+ ((and (has-value? m1) (has-value? m2))
+ (set-value! product
+ (* (get-value m1) (get-value m2))
+ me))
+ ((and (has-value? product) (has-value? m1))
+ (set-value! m2
+ (/ (get-value product) (get-value m1))
+ me))
+ ((and (has-value? product) (has-value? m2))
+ (set-value! m1
+ (/ (get-value product) (get-value m2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! product me)
+ (forget-value! m1 me)
+ (forget-value! m2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- MULTIPLIER" request))))
+ (connect m1 me)
+ (connect m2 me)
+ (connect product me)
+ me)
+
+(define (constant value connector)
+ (define (me request)
+ (error "Unknown request -- CONSTANT" request))
+ (connect connector me)
+ (set-value! connector value me)
+ me)
+
+(define (probe name connector)
+ (define (print-probe value)
+ (newline)
+ (display "Probe: ")
+ (display name)
+ (display " = ")
+ (display value))
+ (define (process-new-value)
+ (print-probe (get-value connector)))
+ (define (process-forget-value)
+ (print-probe "?"))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- PROBE" request))))
+ (connect connector me)
+ me)
+
+(define (make-connector)
+ (let ((value false) (informant false) (constraints '()))
+ (define (set-my-value newval setter)
+ (cond ((not (has-value? me))
+ (set! value newval)
+ (set! informant setter)
+ (for-each-except setter
+ inform-about-value
+ constraints))
+ ((not (= value newval))
+ (error "Contradiction" (list value newval)))
+ (else 'ignored)))
+ (define (forget-my-value retractor)
+ (if (eq? retractor informant)
+ (begin (set! informant false)
+ (for-each-except retractor
+ inform-about-no-value
+ constraints))
+ 'ignored))
+ (define (connect new-constraint)
+ (if (not (memq new-constraint constraints))
+ (set! constraints
+ (cons new-constraint constraints)))
+ (if (has-value? me)
+ (inform-about-value new-constraint))
+ 'done)
+ (define (me request)
+ (cond ((eq? request 'has-value?)
+ (if informant true false))
+ ((eq? request 'value) value)
+ ((eq? request 'set-value!) set-my-value)
+ ((eq? request 'forget) forget-my-value)
+ ((eq? request 'connect) connect)
+ (else (error "Unknown operation -- CONNECTOR"
+ request))))
+ me))
+
+(define (for-each-except exception procedure list)
+ (define (loop items)
+ (cond ((null? items) 'done)
+ ((eq? (car items) exception) (loop (cdr items)))
+ (else (procedure (car items))
+ (loop (cdr items)))))
+ (loop list))
+
+(define (has-value? connector)
+ (connector 'has-value?))
+(define (get-value connector)
+ (connector 'value))
+(define (set-value! connector new-value informant)
+ ((connector 'set-value!) new-value informant))
+(define (forget-value! connector retractor)
+ ((connector 'forget) retractor))
+(define (connect connector new-constraint)
+ ((connector 'connect) new-constraint))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (averager a b c)
+ (let ((sum (make-connector))
+ (two (make-connector)))
+ (adder a b sum)
+ (constant 2 two)
+ (multiplier two c sum)))
+
+;; Exercise 3.34. Louis Reasoner wants to build a squarer, a constraint device with two terminals such that the value of connector b on the second terminal will always be the square of the value a on the first terminal. He proposes the following simple device made from a multiplier:
+
+(define (squarer a b)
+ (multiplier a a b))
+
+;; There is a serious flaw in this idea. Explain.
+
+;; This constraint only works in one direction. If a has a value, then the value is propagated to b. But, if b has a value, the value is not propagated to a because a multiplier normally needs to know one product plus one factor in orer to figure out the value of the second factor. The problem is that the multiplier is unaware that the two factors are referring to the same connector.
blob - /dev/null
blob + 38ef4e404695eda54c23cc8e7a8e51e12ab103b6 (mode 644)
--- /dev/null
+++ ex3-34.scm~
+(define (celsius-fahrenheit-converter c f)
+ (let ((u (make-connector))
+ (v (make-connector))
+ (w (make-connector))
+ (x (make-connector))
+ (y (make-connector)))
+ (multiplier c w u)
+ (multiplier v x u)
+ (adder v y f)
+ (constant 9 w)
+ (constant 5 x)
+ (constant 32 y)
+ 'ok))
+
+(define (adder a1 a2 sum)
+ (define (process-new-value)
+ (cond ((and (has-value? a1) (has-value? a2))
+ (set-value! sum
+ (+ (get-value a1) (get-value a2))
+ me))
+ ((and (has-value? a1) (has-value? sum))
+ (set-value! a2
+ (- (get-value sum) (get-value a1))
+ me))
+ ((and (has-value? a2) (has-value? sum))
+ (set-value! a1
+ (- (get-value sum) (get-value a2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! sum me)
+ (forget-value! a1 me)
+ (forget-value! a2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- ADDER" request))))
+ (connect a1 me)
+ (connect a2 me)
+ (connect sum me)
+ me)
+
+(define (inform-about-value constraint)
+ (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+ (constraint 'I-lost-my-value))
+
+(define (multiplier m1 m2 product)
+ (define (process-new-value)
+ (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+ (and (has-value? m2) (= (get-value m2) 0)))
+ (set-value! product 0 me))
+ ((and (has-value? m1) (has-value? m2))
+ (set-value! product
+ (* (get-value m1) (get-value m2))
+ me))
+ ((and (has-value? product) (has-value? m1))
+ (set-value! m2
+ (/ (get-value product) (get-value m1))
+ me))
+ ((and (has-value? product) (has-value? m2))
+ (set-value! m1
+ (/ (get-value product) (get-value m2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! product me)
+ (forget-value! m1 me)
+ (forget-value! m2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- MULTIPLIER" request))))
+ (connect m1 me)
+ (connect m2 me)
+ (connect product me)
+ me)
+
+(define (constant value connector)
+ (define (me request)
+ (error "Unknown request -- CONSTANT" request))
+ (connect connector me)
+ (set-value! connector value me)
+ me)
+
+(define (probe name connector)
+ (define (print-probe value)
+ (newline)
+ (display "Probe: ")
+ (display name)
+ (display " = ")
+ (display value))
+ (define (process-new-value)
+ (print-probe (get-value connector)))
+ (define (process-forget-value)
+ (print-probe "?"))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- PROBE" request))))
+ (connect connector me)
+ me)
+
+(define (make-connector)
+ (let ((value false) (informant false) (constraints '()))
+ (define (set-my-value newval setter)
+ (cond ((not (has-value? me))
+ (set! value newval)
+ (set! informant setter)
+ (for-each-except setter
+ inform-about-value
+ constraints))
+ ((not (= value newval))
+ (error "Contradiction" (list value newval)))
+ (else 'ignored)))
+ (define (forget-my-value retractor)
+ (if (eq? retractor informant)
+ (begin (set! informant false)
+ (for-each-except retractor
+ inform-about-no-value
+ constraints))
+ 'ignored))
+ (define (connect new-constraint)
+ (if (not (memq new-constraint constraints))
+ (set! constraints
+ (cons new-constraint constraints)))
+ (if (has-value? me)
+ (inform-about-value new-constraint))
+ 'done)
+ (define (me request)
+ (cond ((eq? request 'has-value?)
+ (if informant true false))
+ ((eq? request 'value) value)
+ ((eq? request 'set-value!) set-my-value)
+ ((eq? request 'forget) forget-my-value)
+ ((eq? request 'connect) connect)
+ (else (error "Unknown operation -- CONNECTOR"
+ request))))
+ me))
+
+(define (for-each-except exception procedure list)
+ (define (loop items)
+ (cond ((null? items) 'done)
+ ((eq? (car items) exception) (loop (cdr items)))
+ (else (procedure (car items))
+ (loop (cdr items)))))
+ (loop list))
+
+(define (has-value? connector)
+ (connector 'has-value?))
+(define (get-value connector)
+ (connector 'value))
+(define (set-value! connector new-value informant)
+ ((connector 'set-value!) new-value informant))
+(define (forget-value! connector retractor)
+ ((connector 'forget) retractor))
+(define (connect connector new-constraint)
+ ((connector 'connect) new-constraint))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 3.33. Using primitive multiplier, adder, and constant constraints, define a procedure averager that takes three connectors a, b, and c as inputs and establishes the constraint that the value of c is the average of the values of a and b.
+
+(define (averager a b c)
+ (let ((sum (make-connector))
+ (two (make-connector)))
+ (adder a b sum)
+ (constant 2 two)
+ (multiplier two c sum)))
+
+(define five (make-connector))
+(define three (make-connector))
+(define avg (make-connector))
+(constant 5 five)
+(constant 3 three)
+(averager five three avg)
+(test-case (get-value avg) 4)
blob - /dev/null
blob + 8bec132d35b74b10a679b2f0870398a792f6d88f (mode 644)
--- /dev/null
+++ ex3-35.scm
+(define (celsius-fahrenheit-converter c f)
+ (let ((u (make-connector))
+ (v (make-connector))
+ (w (make-connector))
+ (x (make-connector))
+ (y (make-connector)))
+ (multiplier c w u)
+ (multiplier v x u)
+ (adder v y f)
+ (constant 9 w)
+ (constant 5 x)
+ (constant 32 y)
+ 'ok))
+
+(define (adder a1 a2 sum)
+ (define (process-new-value)
+ (cond ((and (has-value? a1) (has-value? a2))
+ (set-value! sum
+ (+ (get-value a1) (get-value a2))
+ me))
+ ((and (has-value? a1) (has-value? sum))
+ (set-value! a2
+ (- (get-value sum) (get-value a1))
+ me))
+ ((and (has-value? a2) (has-value? sum))
+ (set-value! a1
+ (- (get-value sum) (get-value a2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! sum me)
+ (forget-value! a1 me)
+ (forget-value! a2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- ADDER" request))))
+ (connect a1 me)
+ (connect a2 me)
+ (connect sum me)
+ me)
+
+(define (inform-about-value constraint)
+ (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+ (constraint 'I-lost-my-value))
+
+(define (multiplier m1 m2 product)
+ (define (process-new-value)
+ (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+ (and (has-value? m2) (= (get-value m2) 0)))
+ (set-value! product 0 me))
+ ((and (has-value? m1) (has-value? m2))
+ (set-value! product
+ (* (get-value m1) (get-value m2))
+ me))
+ ((and (has-value? product) (has-value? m1))
+ (set-value! m2
+ (/ (get-value product) (get-value m1))
+ me))
+ ((and (has-value? product) (has-value? m2))
+ (set-value! m1
+ (/ (get-value product) (get-value m2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! product me)
+ (forget-value! m1 me)
+ (forget-value! m2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- MULTIPLIER" request))))
+ (connect m1 me)
+ (connect m2 me)
+ (connect product me)
+ me)
+
+(define (constant value connector)
+ (define (me request)
+ (error "Unknown request -- CONSTANT" request))
+ (connect connector me)
+ (set-value! connector value me)
+ me)
+
+(define (probe name connector)
+ (define (print-probe value)
+ (newline)
+ (display "Probe: ")
+ (display name)
+ (display " = ")
+ (display value))
+ (define (process-new-value)
+ (print-probe (get-value connector)))
+ (define (process-forget-value)
+ (print-probe "?"))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- PROBE" request))))
+ (connect connector me)
+ me)
+
+(define (make-connector)
+ (let ((value false) (informant false) (constraints '()))
+ (define (set-my-value newval setter)
+ (cond ((not (has-value? me))
+ (set! value newval)
+ (set! informant setter)
+ (for-each-except setter
+ inform-about-value
+ constraints))
+ ((not (= value newval))
+ (error "Contradiction" (list value newval)))
+ (else 'ignored)))
+ (define (forget-my-value retractor)
+ (if (eq? retractor informant)
+ (begin (set! informant false)
+ (for-each-except retractor
+ inform-about-no-value
+ constraints))
+ 'ignored))
+ (define (connect new-constraint)
+ (if (not (memq new-constraint constraints))
+ (set! constraints
+ (cons new-constraint constraints)))
+ (if (has-value? me)
+ (inform-about-value new-constraint))
+ 'done)
+ (define (me request)
+ (cond ((eq? request 'has-value?)
+ (if informant true false))
+ ((eq? request 'value) value)
+ ((eq? request 'set-value!) set-my-value)
+ ((eq? request 'forget) forget-my-value)
+ ((eq? request 'connect) connect)
+ (else (error "Unknown operation -- CONNECTOR"
+ request))))
+ me))
+
+(define (for-each-except exception procedure list)
+ (define (loop items)
+ (cond ((null? items) 'done)
+ ((eq? (car items) exception) (loop (cdr items)))
+ (else (procedure (car items))
+ (loop (cdr items)))))
+ (loop list))
+
+(define (has-value? connector)
+ (connector 'has-value?))
+(define (get-value connector)
+ (connector 'value))
+(define (set-value! connector new-value informant)
+ ((connector 'set-value!) new-value informant))
+(define (forget-value! connector retractor)
+ ((connector 'forget) retractor))
+(define (connect connector new-constraint)
+ ((connector 'connect) new-constraint))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (averager a b c)
+ (let ((sum (make-connector))
+ (two (make-connector)))
+ (adder a b sum)
+ (constant 2 two)
+ (multiplier two c sum)))
+
+;; Exercise 3.35. Ben Bitdiddle tells Louis that one way to avoid the trouble in exercise 3.34 is to define a squarer as a new primitive constraint. Fill in the missing portions in Ben's outline for a procedure to implement such a constraint:
+
+(define (squarer a b)
+ (define (process-new-value)
+ (if (has-value? b)
+ (if (< (get-value b) 0)
+ (error "square less than 0 -- SQUARER" (get-value b))
+ (set-value! a
+ (sqrt (get-value b))
+ me))
+ (if (has-value? a)
+ (set-value! b
+ (square (get-value a))
+ me))))
+ (define (process-forget-value)
+ (forget-value! a me)
+ (forget-value! b me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value) (process-new-value))
+ ((eq? request 'I-lost-my-value) (process-forget-value))
+ (else (error "Unknown request -- SQUARER"))))
+ (connect a me)
+ (connect b me)
+ me)
+(define x (make-connector))
+(define x2 (make-connector))
+(squarer x x2)
+(set-value! x 5 'user)
+(test-case (get-value x) 5)
+(test-case (get-value x2) 25)
+(forget-value! x 'user)
+(set-value! x2 7 'user)
+(test-case (get-value x) (sqrt 7))
+(test-case (get-value x2) 7)
+
blob - /dev/null
blob + 721b48cd4f936b6fbfc69bb9a74179fca1cd263d (mode 644)
--- /dev/null
+++ ex3-35.scm~
+(define (celsius-fahrenheit-converter c f)
+ (let ((u (make-connector))
+ (v (make-connector))
+ (w (make-connector))
+ (x (make-connector))
+ (y (make-connector)))
+ (multiplier c w u)
+ (multiplier v x u)
+ (adder v y f)
+ (constant 9 w)
+ (constant 5 x)
+ (constant 32 y)
+ 'ok))
+
+(define (adder a1 a2 sum)
+ (define (process-new-value)
+ (cond ((and (has-value? a1) (has-value? a2))
+ (set-value! sum
+ (+ (get-value a1) (get-value a2))
+ me))
+ ((and (has-value? a1) (has-value? sum))
+ (set-value! a2
+ (- (get-value sum) (get-value a1))
+ me))
+ ((and (has-value? a2) (has-value? sum))
+ (set-value! a1
+ (- (get-value sum) (get-value a2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! sum me)
+ (forget-value! a1 me)
+ (forget-value! a2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- ADDER" request))))
+ (connect a1 me)
+ (connect a2 me)
+ (connect sum me)
+ me)
+
+(define (inform-about-value constraint)
+ (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+ (constraint 'I-lost-my-value))
+
+(define (multiplier m1 m2 product)
+ (define (process-new-value)
+ (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+ (and (has-value? m2) (= (get-value m2) 0)))
+ (set-value! product 0 me))
+ ((and (has-value? m1) (has-value? m2))
+ (set-value! product
+ (* (get-value m1) (get-value m2))
+ me))
+ ((and (has-value? product) (has-value? m1))
+ (set-value! m2
+ (/ (get-value product) (get-value m1))
+ me))
+ ((and (has-value? product) (has-value? m2))
+ (set-value! m1
+ (/ (get-value product) (get-value m2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! product me)
+ (forget-value! m1 me)
+ (forget-value! m2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- MULTIPLIER" request))))
+ (connect m1 me)
+ (connect m2 me)
+ (connect product me)
+ me)
+
+(define (constant value connector)
+ (define (me request)
+ (error "Unknown request -- CONSTANT" request))
+ (connect connector me)
+ (set-value! connector value me)
+ me)
+
+(define (probe name connector)
+ (define (print-probe value)
+ (newline)
+ (display "Probe: ")
+ (display name)
+ (display " = ")
+ (display value))
+ (define (process-new-value)
+ (print-probe (get-value connector)))
+ (define (process-forget-value)
+ (print-probe "?"))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- PROBE" request))))
+ (connect connector me)
+ me)
+
+(define (make-connector)
+ (let ((value false) (informant false) (constraints '()))
+ (define (set-my-value newval setter)
+ (cond ((not (has-value? me))
+ (set! value newval)
+ (set! informant setter)
+ (for-each-except setter
+ inform-about-value
+ constraints))
+ ((not (= value newval))
+ (error "Contradiction" (list value newval)))
+ (else 'ignored)))
+ (define (forget-my-value retractor)
+ (if (eq? retractor informant)
+ (begin (set! informant false)
+ (for-each-except retractor
+ inform-about-no-value
+ constraints))
+ 'ignored))
+ (define (connect new-constraint)
+ (if (not (memq new-constraint constraints))
+ (set! constraints
+ (cons new-constraint constraints)))
+ (if (has-value? me)
+ (inform-about-value new-constraint))
+ 'done)
+ (define (me request)
+ (cond ((eq? request 'has-value?)
+ (if informant true false))
+ ((eq? request 'value) value)
+ ((eq? request 'set-value!) set-my-value)
+ ((eq? request 'forget) forget-my-value)
+ ((eq? request 'connect) connect)
+ (else (error "Unknown operation -- CONNECTOR"
+ request))))
+ me))
+
+(define (for-each-except exception procedure list)
+ (define (loop items)
+ (cond ((null? items) 'done)
+ ((eq? (car items) exception) (loop (cdr items)))
+ (else (procedure (car items))
+ (loop (cdr items)))))
+ (loop list))
+
+(define (has-value? connector)
+ (connector 'has-value?))
+(define (get-value connector)
+ (connector 'value))
+(define (set-value! connector new-value informant)
+ ((connector 'set-value!) new-value informant))
+(define (forget-value! connector retractor)
+ ((connector 'forget) retractor))
+(define (connect connector new-constraint)
+ ((connector 'connect) new-constraint))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (averager a b c)
+ (let ((sum (make-connector))
+ (two (make-connector)))
+ (adder a b sum)
+ (constant 2 two)
+ (multiplier two c sum)))
+
+;; Exercise 3.34. Louis Reasoner wants to build a squarer, a constraint device with two terminals such that the value of connector b on the second terminal will always be the square of the value a on the first terminal. He proposes the following simple device made from a multiplier:
+
+(define (squarer a b)
+ (multiplier a a b))
+
+;; There is a serious flaw in this idea. Explain.
+
+;; This constraint only works in one direction. If a has a value, then the value is propagated to b. But, if b has a value, the value is not propagated to a because a multiplier normally needs to know one product plus one factor in orer to figure out the value of the second factor. The problem is that the multiplier is unaware that the two factors are referring to the same connector.
blob - /dev/null
blob + 39616c47542b67ccd8686737e346bf4ca9f83617 (mode 644)
--- /dev/null
+++ ex3-36.scm
+(define (celsius-fahrenheit-converter c f)
+ (let ((u (make-connector))
+ (v (make-connector))
+ (w (make-connector))
+ (x (make-connector))
+ (y (make-connector)))
+ (multiplier c w u)
+ (multiplier v x u)
+ (adder v y f)
+ (constant 9 w)
+ (constant 5 x)
+ (constant 32 y)
+ 'ok))
+
+(define (adder a1 a2 sum)
+ (define (process-new-value)
+ (cond ((and (has-value? a1) (has-value? a2))
+ (set-value! sum
+ (+ (get-value a1) (get-value a2))
+ me))
+ ((and (has-value? a1) (has-value? sum))
+ (set-value! a2
+ (- (get-value sum) (get-value a1))
+ me))
+ ((and (has-value? a2) (has-value? sum))
+ (set-value! a1
+ (- (get-value sum) (get-value a2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! sum me)
+ (forget-value! a1 me)
+ (forget-value! a2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- ADDER" request))))
+ (connect a1 me)
+ (connect a2 me)
+ (connect sum me)
+ me)
+
+(define (inform-about-value constraint)
+ (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+ (constraint 'I-lost-my-value))
+
+(define (multiplier m1 m2 product)
+ (define (process-new-value)
+ (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+ (and (has-value? m2) (= (get-value m2) 0)))
+ (set-value! product 0 me))
+ ((and (has-value? m1) (has-value? m2))
+ (set-value! product
+ (* (get-value m1) (get-value m2))
+ me))
+ ((and (has-value? product) (has-value? m1))
+ (set-value! m2
+ (/ (get-value product) (get-value m1))
+ me))
+ ((and (has-value? product) (has-value? m2))
+ (set-value! m1
+ (/ (get-value product) (get-value m2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! product me)
+ (forget-value! m1 me)
+ (forget-value! m2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- MULTIPLIER" request))))
+ (connect m1 me)
+ (connect m2 me)
+ (connect product me)
+ me)
+
+(define (constant value connector)
+ (define (me request)
+ (error "Unknown request -- CONSTANT" request))
+ (connect connector me)
+ (set-value! connector value me)
+ me)
+
+(define (probe name connector)
+ (define (print-probe value)
+ (newline)
+ (display "Probe: ")
+ (display name)
+ (display " = ")
+ (display value))
+ (define (process-new-value)
+ (print-probe (get-value connector)))
+ (define (process-forget-value)
+ (print-probe "?"))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- PROBE" request))))
+ (connect connector me)
+ me)
+
+(define (make-connector)
+ (let ((value false) (informant false) (constraints '()))
+ (define (set-my-value newval setter)
+ (cond ((not (has-value? me))
+ (set! value newval)
+ (set! informant setter)
+ (for-each-except setter
+ inform-about-value
+ constraints))
+ ((not (= value newval))
+ (error "Contradiction" (list value newval)))
+ (else 'ignored)))
+ (define (forget-my-value retractor)
+ (if (eq? retractor informant)
+ (begin (set! informant false)
+ (for-each-except retractor
+ inform-about-no-value
+ constraints))
+ 'ignored))
+ (define (connect new-constraint)
+ (if (not (memq new-constraint constraints))
+ (set! constraints
+ (cons new-constraint constraints)))
+ (if (has-value? me)
+ (inform-about-value new-constraint))
+ 'done)
+ (define (me request)
+ (cond ((eq? request 'has-value?)
+ (if informant true false))
+ ((eq? request 'value) value)
+ ((eq? request 'set-value!) set-my-value)
+ ((eq? request 'forget) forget-my-value)
+ ((eq? request 'connect) connect)
+ (else (error "Unknown operation -- CONNECTOR"
+ request))))
+ me))
+
+(define (for-each-except exception procedure list)
+ (define (loop items)
+ (cond ((null? items) 'done)
+ ((eq? (car items) exception) (loop (cdr items)))
+ (else (procedure (car items))
+ (loop (cdr items)))))
+ (loop list))
+
+(define (has-value? connector)
+ (connector 'has-value?))
+(define (get-value connector)
+ (connector 'value))
+(define (set-value! connector new-value informant)
+ ((connector 'set-value!) new-value informant))
+(define (forget-value! connector retractor)
+ ((connector 'forget) retractor))
+(define (connect connector new-constraint)
+ ((connector 'connect) new-constraint))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (averager a b c)
+ (let ((sum (make-connector))
+ (two (make-connector)))
+ (adder a b sum)
+ (constant 2 two)
+ (multiplier two c sum)))
+
+(define (squarer a b)
+ (define (process-new-value)
+ (if (has-value? b)
+ (if (< (get-value b) 0)
+ (error "square less than 0 -- SQUARER" (get-value b))
+ (set-value! a
+ (sqrt (get-value b))
+ me))
+ (if (has-value? a)
+ (set-value! b
+ (square (get-value a))
+ me))))
+ (define (process-forget-value)
+ (forget-value! a me)
+ (forget-value! b me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value) (process-new-value))
+ ((eq? request 'I-lost-my-value) (process-forget-value))
+ (else (error "Unknown request -- SQUARER"))))
+ (connect a me)
+ (connect b me)
+ me)
+
+;; Exercise 3.36. Suppose we evaluate the following sequence of expressions in the global environment:
+
+(define a (make-connector))
+(define b (make-connector))
+(set-value! a 10 'user)
+
+;; At some time during evaluation of the set-value!, the following expression from the connector's local procedure is evaluated:
+
+(for-each-except setter inform-about-value constraints)
+
+;; Draw an environment diagram showing the environment in which the above expression is evaluated.
blob - /dev/null
blob + 6f7484b12b14ceecefbd8563065c1d5c42031dd8 (mode 644)
--- /dev/null
+++ ex3-36.scm~
+(define (celsius-fahrenheit-converter c f)
+ (let ((u (make-connector))
+ (v (make-connector))
+ (w (make-connector))
+ (x (make-connector))
+ (y (make-connector)))
+ (multiplier c w u)
+ (multiplier v x u)
+ (adder v y f)
+ (constant 9 w)
+ (constant 5 x)
+ (constant 32 y)
+ 'ok))
+
+(define (adder a1 a2 sum)
+ (define (process-new-value)
+ (cond ((and (has-value? a1) (has-value? a2))
+ (set-value! sum
+ (+ (get-value a1) (get-value a2))
+ me))
+ ((and (has-value? a1) (has-value? sum))
+ (set-value! a2
+ (- (get-value sum) (get-value a1))
+ me))
+ ((and (has-value? a2) (has-value? sum))
+ (set-value! a1
+ (- (get-value sum) (get-value a2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! sum me)
+ (forget-value! a1 me)
+ (forget-value! a2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- ADDER" request))))
+ (connect a1 me)
+ (connect a2 me)
+ (connect sum me)
+ me)
+
+(define (inform-about-value constraint)
+ (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+ (constraint 'I-lost-my-value))
+
+(define (multiplier m1 m2 product)
+ (define (process-new-value)
+ (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+ (and (has-value? m2) (= (get-value m2) 0)))
+ (set-value! product 0 me))
+ ((and (has-value? m1) (has-value? m2))
+ (set-value! product
+ (* (get-value m1) (get-value m2))
+ me))
+ ((and (has-value? product) (has-value? m1))
+ (set-value! m2
+ (/ (get-value product) (get-value m1))
+ me))
+ ((and (has-value? product) (has-value? m2))
+ (set-value! m1
+ (/ (get-value product) (get-value m2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! product me)
+ (forget-value! m1 me)
+ (forget-value! m2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- MULTIPLIER" request))))
+ (connect m1 me)
+ (connect m2 me)
+ (connect product me)
+ me)
+
+(define (constant value connector)
+ (define (me request)
+ (error "Unknown request -- CONSTANT" request))
+ (connect connector me)
+ (set-value! connector value me)
+ me)
+
+(define (probe name connector)
+ (define (print-probe value)
+ (newline)
+ (display "Probe: ")
+ (display name)
+ (display " = ")
+ (display value))
+ (define (process-new-value)
+ (print-probe (get-value connector)))
+ (define (process-forget-value)
+ (print-probe "?"))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- PROBE" request))))
+ (connect connector me)
+ me)
+
+(define (make-connector)
+ (let ((value false) (informant false) (constraints '()))
+ (define (set-my-value newval setter)
+ (cond ((not (has-value? me))
+ (set! value newval)
+ (set! informant setter)
+ (for-each-except setter
+ inform-about-value
+ constraints))
+ ((not (= value newval))
+ (error "Contradiction" (list value newval)))
+ (else 'ignored)))
+ (define (forget-my-value retractor)
+ (if (eq? retractor informant)
+ (begin (set! informant false)
+ (for-each-except retractor
+ inform-about-no-value
+ constraints))
+ 'ignored))
+ (define (connect new-constraint)
+ (if (not (memq new-constraint constraints))
+ (set! constraints
+ (cons new-constraint constraints)))
+ (if (has-value? me)
+ (inform-about-value new-constraint))
+ 'done)
+ (define (me request)
+ (cond ((eq? request 'has-value?)
+ (if informant true false))
+ ((eq? request 'value) value)
+ ((eq? request 'set-value!) set-my-value)
+ ((eq? request 'forget) forget-my-value)
+ ((eq? request 'connect) connect)
+ (else (error "Unknown operation -- CONNECTOR"
+ request))))
+ me))
+
+(define (for-each-except exception procedure list)
+ (define (loop items)
+ (cond ((null? items) 'done)
+ ((eq? (car items) exception) (loop (cdr items)))
+ (else (procedure (car items))
+ (loop (cdr items)))))
+ (loop list))
+
+(define (has-value? connector)
+ (connector 'has-value?))
+(define (get-value connector)
+ (connector 'value))
+(define (set-value! connector new-value informant)
+ ((connector 'set-value!) new-value informant))
+(define (forget-value! connector retractor)
+ ((connector 'forget) retractor))
+(define (connect connector new-constraint)
+ ((connector 'connect) new-constraint))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (averager a b c)
+ (let ((sum (make-connector))
+ (two (make-connector)))
+ (adder a b sum)
+ (constant 2 two)
+ (multiplier two c sum)))
+
+(define (squarer a b)
+ (define (process-new-value)
+ (if (has-value? b)
+ (if (< (get-value b) 0)
+ (error "square less than 0 -- SQUARER" (get-value b))
+ (set-value! a
+ (sqrt (get-value b))
+ me))
+ (if (has-value? a)
+ (set-value! b
+ (square (get-value a))
+ me))))
+ (define (process-forget-value)
+ (forget-value! a me)
+ (forget-value! b me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value) (process-new-value))
+ ((eq? request 'I-lost-my-value) (process-forget-value))
+ (else (error "Unknown request -- SQUARER"))))
+ (connect a me)
+ (connect b me)
+ me)
+
+;; Exercise 3.36. Suppose we evaluate the following sequence of expressions in the global environment:
+
+(define a (make-connector))
+(define b (make-connector))
+(set-value! a 10 'user)
+
+At some time during evaluation of the set-value!, the following expression from the connector's local procedure is evaluated:
+
+(for-each-except setter inform-about-value constraints)
+
+Draw an environment diagram showing the environment in which the above expression is evaluated.
blob - /dev/null
blob + 093e3e3937840b4faef26e20fa63463fae7b548a (mode 644)
--- /dev/null
+++ ex3-37.scm
+(define (celsius-fahrenheit-converter c f)
+ (let ((u (make-connector))
+ (v (make-connector))
+ (w (make-connector))
+ (x (make-connector))
+ (y (make-connector)))
+ (multiplier c w u)
+ (multiplier v x u)
+ (adder v y f)
+ (constant 9 w)
+ (constant 5 x)
+ (constant 32 y)
+ 'ok))
+
+(define (adder a1 a2 sum)
+ (define (process-new-value)
+ (cond ((and (has-value? a1) (has-value? a2))
+ (set-value! sum
+ (+ (get-value a1) (get-value a2))
+ me))
+ ((and (has-value? a1) (has-value? sum))
+ (set-value! a2
+ (- (get-value sum) (get-value a1))
+ me))
+ ((and (has-value? a2) (has-value? sum))
+ (set-value! a1
+ (- (get-value sum) (get-value a2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! sum me)
+ (forget-value! a1 me)
+ (forget-value! a2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- ADDER" request))))
+ (connect a1 me)
+ (connect a2 me)
+ (connect sum me)
+ me)
+
+(define (inform-about-value constraint)
+ (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+ (constraint 'I-lost-my-value))
+
+(define (multiplier m1 m2 product)
+ (define (process-new-value)
+ (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+ (and (has-value? m2) (= (get-value m2) 0)))
+ (set-value! product 0 me))
+ ((and (has-value? m1) (has-value? m2))
+ (set-value! product
+ (* (get-value m1) (get-value m2))
+ me))
+ ((and (has-value? product) (has-value? m1))
+ (set-value! m2
+ (/ (get-value product) (get-value m1))
+ me))
+ ((and (has-value? product) (has-value? m2))
+ (set-value! m1
+ (/ (get-value product) (get-value m2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! product me)
+ (forget-value! m1 me)
+ (forget-value! m2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- MULTIPLIER" request))))
+ (connect m1 me)
+ (connect m2 me)
+ (connect product me)
+ me)
+
+(define (constant value connector)
+ (define (me request)
+ (error "Unknown request -- CONSTANT" request))
+ (connect connector me)
+ (set-value! connector value me)
+ me)
+
+(define (probe name connector)
+ (define (print-probe value)
+ (newline)
+ (display "Probe: ")
+ (display name)
+ (display " = ")
+ (display value))
+ (define (process-new-value)
+ (print-probe (get-value connector)))
+ (define (process-forget-value)
+ (print-probe "?"))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- PROBE" request))))
+ (connect connector me)
+ me)
+
+(define (make-connector)
+ (let ((value false) (informant false) (constraints '()))
+ (define (set-my-value newval setter)
+ (cond ((not (has-value? me))
+ (set! value newval)
+ (set! informant setter)
+ (for-each-except setter
+ inform-about-value
+ constraints))
+ ((not (= value newval))
+ (error "Contradiction" (list value newval)))
+ (else 'ignored)))
+ (define (forget-my-value retractor)
+ (if (eq? retractor informant)
+ (begin (set! informant false)
+ (for-each-except retractor
+ inform-about-no-value
+ constraints))
+ 'ignored))
+ (define (connect new-constraint)
+ (if (not (memq new-constraint constraints))
+ (set! constraints
+ (cons new-constraint constraints)))
+ (if (has-value? me)
+ (inform-about-value new-constraint))
+ 'done)
+ (define (me request)
+ (cond ((eq? request 'has-value?)
+ (if informant true false))
+ ((eq? request 'value) value)
+ ((eq? request 'set-value!) set-my-value)
+ ((eq? request 'forget) forget-my-value)
+ ((eq? request 'connect) connect)
+ (else (error "Unknown operation -- CONNECTOR"
+ request))))
+ me))
+
+(define (for-each-except exception procedure list)
+ (define (loop items)
+ (cond ((null? items) 'done)
+ ((eq? (car items) exception) (loop (cdr items)))
+ (else (procedure (car items))
+ (loop (cdr items)))))
+ (loop list))
+
+(define (has-value? connector)
+ (connector 'has-value?))
+(define (get-value connector)
+ (connector 'value))
+(define (set-value! connector new-value informant)
+ ((connector 'set-value!) new-value informant))
+(define (forget-value! connector retractor)
+ ((connector 'forget) retractor))
+(define (connect connector new-constraint)
+ ((connector 'connect) new-constraint))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (averager a b c)
+ (let ((sum (make-connector))
+ (two (make-connector)))
+ (adder a b sum)
+ (constant 2 two)
+ (multiplier two c sum)))
+
+(define (squarer a b)
+ (define (process-new-value)
+ (if (has-value? b)
+ (if (< (get-value b) 0)
+ (error "square less than 0 -- SQUARER" (get-value b))
+ (set-value! a
+ (sqrt (get-value b))
+ me))
+ (if (has-value? a)
+ (set-value! b
+ (square (get-value a))
+ me))))
+ (define (process-forget-value)
+ (forget-value! a me)
+ (forget-value! b me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value) (process-new-value))
+ ((eq? request 'I-lost-my-value) (process-forget-value))
+ (else (error "Unknown request -- SQUARER"))))
+ (connect a me)
+ (connect b me)
+ me)
+
+;; Exercise 3.37. The celsius-fahrenheit-converter procedure is cumbersome when compared with a more expression-oriented style of definition, such as
+
+;; Here c+, c*, etc. are the ``constraint'' versions of the arithmetic operations. For example, c+ takes two connectors as arguments and returns a connector that is related to these by an adder constraint:
+
+(define (c+ x y)
+ (let ((z (make-connector)))
+ (adder x y z)
+ z))
+
+;; Define analogous procedures c-, c*, c/, and cv (constant value) that enable us to define compound constraints as in the converter example above.
+
+(define (c- x y)
+ (let ((z (make-connector)))
+ (adder z y x)
+ z))
+
+(define (c* x y)
+ (let ((z (make-connector)))
+ (multiplier x y z)
+ z))
+
+(define (c/ x y)
+ (let ((z (make-connector)))
+ (multiplier z y x)
+ z))
+
+(define (cv const)
+ (let ((z (make-connector)))
+ (constant const z)
+ z))
+
+(define (celsius-fahrenheit-converter x)
+ (c+ (c* (c/ (cv 9) (cv 5))
+ x)
+ (cv 32)))
+(define C (make-connector))
+(define F (celsius-fahrenheit-converter C))
+
+(set-value! C 35 'user)
+(test-case (get-value F) 95)
+(forget-value! C 'user)
+(set-value! F 302 'user)
+(test-case (get-value C) 150)
blob - /dev/null
blob + 39616c47542b67ccd8686737e346bf4ca9f83617 (mode 644)
--- /dev/null
+++ ex3-37.scm~
+(define (celsius-fahrenheit-converter c f)
+ (let ((u (make-connector))
+ (v (make-connector))
+ (w (make-connector))
+ (x (make-connector))
+ (y (make-connector)))
+ (multiplier c w u)
+ (multiplier v x u)
+ (adder v y f)
+ (constant 9 w)
+ (constant 5 x)
+ (constant 32 y)
+ 'ok))
+
+(define (adder a1 a2 sum)
+ (define (process-new-value)
+ (cond ((and (has-value? a1) (has-value? a2))
+ (set-value! sum
+ (+ (get-value a1) (get-value a2))
+ me))
+ ((and (has-value? a1) (has-value? sum))
+ (set-value! a2
+ (- (get-value sum) (get-value a1))
+ me))
+ ((and (has-value? a2) (has-value? sum))
+ (set-value! a1
+ (- (get-value sum) (get-value a2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! sum me)
+ (forget-value! a1 me)
+ (forget-value! a2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- ADDER" request))))
+ (connect a1 me)
+ (connect a2 me)
+ (connect sum me)
+ me)
+
+(define (inform-about-value constraint)
+ (constraint 'I-have-a-value))
+(define (inform-about-no-value constraint)
+ (constraint 'I-lost-my-value))
+
+(define (multiplier m1 m2 product)
+ (define (process-new-value)
+ (cond ((or (and (has-value? m1) (= (get-value m1) 0))
+ (and (has-value? m2) (= (get-value m2) 0)))
+ (set-value! product 0 me))
+ ((and (has-value? m1) (has-value? m2))
+ (set-value! product
+ (* (get-value m1) (get-value m2))
+ me))
+ ((and (has-value? product) (has-value? m1))
+ (set-value! m2
+ (/ (get-value product) (get-value m1))
+ me))
+ ((and (has-value? product) (has-value? m2))
+ (set-value! m1
+ (/ (get-value product) (get-value m2))
+ me))))
+ (define (process-forget-value)
+ (forget-value! product me)
+ (forget-value! m1 me)
+ (forget-value! m2 me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- MULTIPLIER" request))))
+ (connect m1 me)
+ (connect m2 me)
+ (connect product me)
+ me)
+
+(define (constant value connector)
+ (define (me request)
+ (error "Unknown request -- CONSTANT" request))
+ (connect connector me)
+ (set-value! connector value me)
+ me)
+
+(define (probe name connector)
+ (define (print-probe value)
+ (newline)
+ (display "Probe: ")
+ (display name)
+ (display " = ")
+ (display value))
+ (define (process-new-value)
+ (print-probe (get-value connector)))
+ (define (process-forget-value)
+ (print-probe "?"))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value)
+ (process-new-value))
+ ((eq? request 'I-lost-my-value)
+ (process-forget-value))
+ (else
+ (error "Unknown request -- PROBE" request))))
+ (connect connector me)
+ me)
+
+(define (make-connector)
+ (let ((value false) (informant false) (constraints '()))
+ (define (set-my-value newval setter)
+ (cond ((not (has-value? me))
+ (set! value newval)
+ (set! informant setter)
+ (for-each-except setter
+ inform-about-value
+ constraints))
+ ((not (= value newval))
+ (error "Contradiction" (list value newval)))
+ (else 'ignored)))
+ (define (forget-my-value retractor)
+ (if (eq? retractor informant)
+ (begin (set! informant false)
+ (for-each-except retractor
+ inform-about-no-value
+ constraints))
+ 'ignored))
+ (define (connect new-constraint)
+ (if (not (memq new-constraint constraints))
+ (set! constraints
+ (cons new-constraint constraints)))
+ (if (has-value? me)
+ (inform-about-value new-constraint))
+ 'done)
+ (define (me request)
+ (cond ((eq? request 'has-value?)
+ (if informant true false))
+ ((eq? request 'value) value)
+ ((eq? request 'set-value!) set-my-value)
+ ((eq? request 'forget) forget-my-value)
+ ((eq? request 'connect) connect)
+ (else (error "Unknown operation -- CONNECTOR"
+ request))))
+ me))
+
+(define (for-each-except exception procedure list)
+ (define (loop items)
+ (cond ((null? items) 'done)
+ ((eq? (car items) exception) (loop (cdr items)))
+ (else (procedure (car items))
+ (loop (cdr items)))))
+ (loop list))
+
+(define (has-value? connector)
+ (connector 'has-value?))
+(define (get-value connector)
+ (connector 'value))
+(define (set-value! connector new-value informant)
+ ((connector 'set-value!) new-value informant))
+(define (forget-value! connector retractor)
+ ((connector 'forget) retractor))
+(define (connect connector new-constraint)
+ ((connector 'connect) new-constraint))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (averager a b c)
+ (let ((sum (make-connector))
+ (two (make-connector)))
+ (adder a b sum)
+ (constant 2 two)
+ (multiplier two c sum)))
+
+(define (squarer a b)
+ (define (process-new-value)
+ (if (has-value? b)
+ (if (< (get-value b) 0)
+ (error "square less than 0 -- SQUARER" (get-value b))
+ (set-value! a
+ (sqrt (get-value b))
+ me))
+ (if (has-value? a)
+ (set-value! b
+ (square (get-value a))
+ me))))
+ (define (process-forget-value)
+ (forget-value! a me)
+ (forget-value! b me)
+ (process-new-value))
+ (define (me request)
+ (cond ((eq? request 'I-have-a-value) (process-new-value))
+ ((eq? request 'I-lost-my-value) (process-forget-value))
+ (else (error "Unknown request -- SQUARER"))))
+ (connect a me)
+ (connect b me)
+ me)
+
+;; Exercise 3.36. Suppose we evaluate the following sequence of expressions in the global environment:
+
+(define a (make-connector))
+(define b (make-connector))
+(set-value! a 10 'user)
+
+;; At some time during evaluation of the set-value!, the following expression from the connector's local procedure is evaluated:
+
+(for-each-except setter inform-about-value constraints)
+
+;; Draw an environment diagram showing the environment in which the above expression is evaluated.
blob - /dev/null
blob + da091ab0bbe7f49624ac863b1ce3b364b25c7268 (mode 644)
--- /dev/null
+++ ex3-38.scm
+(define x 10)
+(define s (make-serializer))
+(parallel-execute (s (lambda () (set! x (* x x))))
+ (s (lambda () (set! x (+ x 1)))))
+
+(define (make-account balance)
+ (define (withdraw amount)
+ (if (>= balance amount)
+ (begin (set! balance (- balance amount))
+ balance)
+ "Insufficient funds"))
+ (define (deposit amount)
+ (set! balance (+ balance amount))
+ balance)
+ (let ((protected (make-serializer)))
+ (define (dispatch m)
+ (cond ((eq? m 'withdraw) (protected withdraw))
+ ((eq? m 'deposit) (protected deposit))
+ (else (error "Unknown request -- MAKE-ACCOUT" m))))
+ dispatch))
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 091143f55342c30411394c4c549e52a9df9352a6 (mode 644)
--- /dev/null
+++ ex3-39.scm
+;; Exercise 3.39. Which of the five possibilities in the parallel execution shown above remain if we instead serialize execution as follows:
+
+(define x 10)
+(define s (make-serializer))
+(parallel-execute (lambda () (set! x ((s (lambda () (* x x))))))
+ (s (lambda () (set! x (+ x 1)))))
+
+;; 101
+;; 121
+;; 100
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + b7d0d18db83294e975a0068f99dae32d0431b3ef (mode 644)
--- /dev/null
+++ ex3-40.scm
+;; Exercise 3.40. Give all possible values of x that can result from executing
+
+(define x 10)
+
+(parallel-execute (lambda () (set! x (* x x)))
+ (lambda () (set! x (* x x x))))
+
+;; 10^2, 10^3, 10^4, 10^5, 10^6
+
+;; Which of these possibilities remain if we instead use serialized procedures:
+
+(define x 10)
+
+(define s (make-serializer))
+
+(parallel-execute (s (lambda () (set! x (* x x))))
+ (s (lambda () (set! x (* x x x)))))
+
+;; 10^6
blob - /dev/null
blob + f9dfd5990a16fff29b92f9528d7393365156ae73 (mode 644)
--- /dev/null
+++ ex3-40.scm~
+ Exercise 3.40. Give all possible values of x that can result from executing
+
+(define x 10)
+
+(parallel-execute (lambda () (set! x (* x x)))
+ (lambda () (set! x (* x x x))))
+
+Which of these possibilities remain if we instead use serialized procedures:
+
+(define x 10)
+
+(define s (make-serializer))
+
+(parallel-execute (s (lambda () (set! x (* x x))))
+ (s (lambda () (set! x (* x x x)))))
blob - /dev/null
blob + fc71d4d9f67115e1f8dba90d8dc0214f88a08720 (mode 644)
--- /dev/null
+++ ex3-41.scm
+;; Exercise 3.41. Ben Bitdiddle worries that it would be better to implement the bank account as follows (where the commented line has been changed):
+
+(define (make-account balance)
+ (define (withdraw amount)
+ (if (>= balance amount)
+ (begin (set! balance (- balance amount))
+ balance)
+ "Insufficient funds"))
+ (define (deposit amount)
+ (set! balance (+ balance amount))
+ balance)
+ ;; continued on next page
+
+ (let ((protected (make-serializer)))
+ (define (dispatch m)
+ (cond ((eq? m 'withdraw) (protected withdraw))
+ ((eq? m 'deposit) (protected deposit))
+ ((eq? m 'balance)
+ ((protected (lambda () balance)))) ; serialized
+ (else (error "Unknown request -- MAKE-ACCOUNT"
+ m))))
+ dispatch))
+
+;; because allowing unserialized access to the bank balance can result in anomalous behavior. Do you agree? Is there any scenario that demonstrates Ben's concern?
+
+
+;; No, this is unnecessary. By the time you use the balance value, it might possibly be out-of-date anyway, whether you serialize it or not.
+
+;; The reason there is no need to serialize is because the result of balance does not depend on any other pieces of shared state that might be changed after the procedure begins but before it completes. There is no way to interleave events (since there is only one instruction), and so the result will be the same as though the processes were executed sequentially.
blob - /dev/null
blob + 01a0497acfd3fc0e163afa0c23b7770895b775aa (mode 644)
--- /dev/null
+++ ex3-41.scm~
+ Exercise 3.41. Ben Bitdiddle worries that it would be better to implement the bank account as follows (where the commented line has been changed):
+
+(define (make-account balance)
+ (define (withdraw amount)
+ (if (>= balance amount)
+ (begin (set! balance (- balance amount))
+ balance)
+ "Insufficient funds"))
+ (define (deposit amount)
+ (set! balance (+ balance amount))
+ balance)
+ ;; continued on next page
+
+ (let ((protected (make-serializer)))
+ (define (dispatch m)
+ (cond ((eq? m 'withdraw) (protected withdraw))
+ ((eq? m 'deposit) (protected deposit))
+ ((eq? m 'balance)
+ ((protected (lambda () balance)))) ; serialized
+ (else (error "Unknown request -- MAKE-ACCOUNT"
+ m))))
+ dispatch))
+
+;; because allowing unserialized access to the bank balance can result in anomalous behavior. Do you agree? Is there any scenario that demonstrates Ben's concern?
blob - /dev/null
blob + 9e3223eee4228b95620394613f35851905380785 (mode 644)
--- /dev/null
+++ ex3-42.scm
+;; Exercise 3.42. Ben Bitdiddle suggests that it's a waste of time to create a new serialized procedure in response to every withdraw and deposit message. He says that make-account could be changed so that the calls to protected are done outside the dispatch procedure. That is, an account would return the same serialized procedure (which was created at the same time as the account) each time it is asked for a withdrawal procedure.
+
+(define (make-account balance)
+ (define (withdraw amount)
+ (if (>= balance amount)
+ (begin (set! balance (- balance amount))
+ balance)
+ "Insufficient funds"))
+ (define (deposit amount)
+ (set! balance (+ balance amount))
+ balance)
+ (let ((protected (make-serializer)))
+ (let ((protected-withdraw (protected withdraw))
+ (protected-deposit (protected deposit)))
+ (define (dispatch m)
+ (cond ((eq? m 'withdraw) protected-withdraw)
+ ((eq? m 'deposit) protected-deposit)
+ ((eq? m 'balance) balance)
+ (else (error "Unknown request -- MAKE-ACCOUNT"
+ m))))
+ dispatch)))
+
+;; Is this a safe change to make? In particular, is there any difference in what concurrency is allowed by these two versions of make-account ?
+
+;; Yes, it's safe.
+
+;; At first I was concerned because I thought if you had a reference to the exact same procedure, you might be able to execute that same procedure again before another execution of that procedure terminated. The thing is that protected-withdraw and protected-deposit will return the exact same procedure whereas (protected withdraw) and (protected deposit) return new procedures each time. However, this does not matter if you check the implementation of the serializer. This is because only one mutex can be acquired, and it does not matter if the exact same procedure tries to grab the mutex -- only one procedure can run at any given time. Trying to run two instances of the exact same procedure will also fail.
blob - /dev/null
blob + 46549ad4e95ddce91dbd4ebbfe0eb99adbc0b4d5 (mode 644)
--- /dev/null
+++ ex3-42.scm~
+ Exercise 3.42. Ben Bitdiddle suggests that it's a waste of time to create a new serialized procedure in response to every withdraw and deposit message. He says that make-account could be changed so that the calls to protected are done outside the dispatch procedure. That is, an account would return the same serialized procedure (which was created at the same time as the account) each time it is asked for a withdrawal procedure.
+
+(define (make-account balance)
+ (define (withdraw amount)
+ (if (>= balance amount)
+ (begin (set! balance (- balance amount))
+ balance)
+ "Insufficient funds"))
+ (define (deposit amount)
+ (set! balance (+ balance amount))
+ balance)
+ (let ((protected (make-serializer)))
+ (let ((protected-withdraw (protected withdraw))
+ (protected-deposit (protected deposit)))
+ (define (dispatch m)
+ (cond ((eq? m 'withdraw) protected-withdraw)
+ ((eq? m 'deposit) protected-deposit)
+ ((eq? m 'balance) balance)
+ (else (error "Unknown request -- MAKE-ACCOUNT"
+ m))))
+ dispatch)))
+
+Is this a safe change to make? In particular, is there any difference in what concurrency is allowed by these two versions of make-account ?
blob - /dev/null
blob + beaa357d27271550854cadf3b5859a255f1a7618 (mode 644)
--- /dev/null
+++ ex3-43.scm
+(define (exchange account1 account2)
+ (let ((difference (- (account1 'balance)
+ (account2 'balance))))
+ ((account1 'withdraw) difference)
+ ((account2 'deposit) difference)))
+
+(define (make-account-and-serializer balance)
+ (define (withdraw amount)
+ (if (>= balance amount)
+ (begin (set! balance (- balance amount))
+ balance)
+ "Insufficient funds"))
+ (define (deposit amount)
+ (set! balance (+ balance amount))
+ balance)
+ (let ((balance-serializer (make-serializer)))
+ (define (dispatch m)
+ (cond ((eq? m 'withdraw) withdraw)
+ ((eq? m 'deposit) deposit)
+ ((eq? m 'balance) balance)
+ ((eq? m 'serializer) balance-serializer)
+ (else (error "Unknown request -- MAKE-ACCOUT"
+ m))))
+ dispatch))
+
+(define (deposit account amount)
+ (let ((s (account 'serializer))
+ (d (account 'deposit)))
+ ((s d) amount)))
+
+(define (serialized-exchange account1 account2)
+ (let ((serializer1 (account1 'serializer))
+ (serializer2 (account2 'serializer)))
+ ((serializer1 (serializer2 exchange))
+ account1
+ account2)))
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + d60a7a6b7e4a8a2aa479ebd8e4f9473250753c23 (mode 644)
--- /dev/null
+++ ex3-44.scm
+(define (exchange account1 account2)
+ (let ((difference (- (account1 'balance)
+ (account2 'balance))))
+ ((account1 'withdraw) difference)
+ ((account2 'deposit) difference)))
+
+(define (make-account-and-serializer balance)
+ (define (withdraw amount)
+ (if (>= balance amount)
+ (begin (set! balance (- balance amount))
+ balance)
+ "Insufficient funds"))
+ (define (deposit amount)
+ (set! balance (+ balance amount))
+ balance)
+ (let ((balance-serializer (make-serializer)))
+ (define (dispatch m)
+ (cond ((eq? m 'withdraw) withdraw)
+ ((eq? m 'deposit) deposit)
+ ((eq? m 'balance) balance)
+ ((eq? m 'serializer) balance-serializer)
+ (else (error "Unknown request -- MAKE-ACCOUT"
+ m))))
+ dispatch))
+
+(define (deposit account amount)
+ (let ((s (account 'serializer))
+ (d (account 'deposit)))
+ ((s d) amount)))
+
+(define (serialized-exchange account1 account2)
+ (let ((serializer1 (account1 'serializer))
+ (serializer2 (account2 'serializer)))
+ ((serializer1 (serializer2 exchange))
+ account1
+ account2)))
+
+;; Exercise 3.44. Consider the problem of transferring an amount from one account to another. Ben Bitdiddle claims that this can be accomplished with the following procedure, even if there are multiple people concurrently transferring money among multiple accounts, using any account mechanism that serializes deposit and withdrawal transactions, for example, the version of make-account in the text above.
+
+(define (transfer from-account to-account amount)
+ ((from-account 'withdraw) amount)
+ ((to-account 'deposit) amount))
+
+;; Louis Reasoner claims that there is a problem here, and that we need to use a more sophisticated method, such as the one required for dealing with the exchange problem. Is Louis right? If not, what is the essential difference between the transfer problem and the exchange problem? (You should assume that the balance in from-account is at least amount.)
+
+;; Louis is wrong. The difference here is that the value in amount is still valid even if other processes change the balances within the two accounts. With difference, if any of the balances change, the amount that needs to be transferred is no longer valid. That is why if two processes alter any of the same accounts, the events cannot be interleaved. However, here, the amount that needs to be transferred will still be valid even if other processes change any of the accounts concurrently.
blob - /dev/null
blob + beaa357d27271550854cadf3b5859a255f1a7618 (mode 644)
--- /dev/null
+++ ex3-44.scm~
+(define (exchange account1 account2)
+ (let ((difference (- (account1 'balance)
+ (account2 'balance))))
+ ((account1 'withdraw) difference)
+ ((account2 'deposit) difference)))
+
+(define (make-account-and-serializer balance)
+ (define (withdraw amount)
+ (if (>= balance amount)
+ (begin (set! balance (- balance amount))
+ balance)
+ "Insufficient funds"))
+ (define (deposit amount)
+ (set! balance (+ balance amount))
+ balance)
+ (let ((balance-serializer (make-serializer)))
+ (define (dispatch m)
+ (cond ((eq? m 'withdraw) withdraw)
+ ((eq? m 'deposit) deposit)
+ ((eq? m 'balance) balance)
+ ((eq? m 'serializer) balance-serializer)
+ (else (error "Unknown request -- MAKE-ACCOUT"
+ m))))
+ dispatch))
+
+(define (deposit account amount)
+ (let ((s (account 'serializer))
+ (d (account 'deposit)))
+ ((s d) amount)))
+
+(define (serialized-exchange account1 account2)
+ (let ((serializer1 (account1 'serializer))
+ (serializer2 (account2 'serializer)))
+ ((serializer1 (serializer2 exchange))
+ account1
+ account2)))
blob - /dev/null
blob + 0fac7afe58098164c9c198a07f2875b620692045 (mode 644)
--- /dev/null
+++ ex3-45.scm
+;; Exercise 3.45. Louis Reasoner thinks our bank-account system is unnecessarily complex and error-prone now that deposits and withdrawals aren't automatically serialized. He suggests that make-account-and-serializer should have exported the serializer (for use by such procedures as serialized-exchange) in addition to (rather than instead of) using it to serialize accounts and deposits as make-account did. He proposes to redefine accounts as follows:
+
+(define (make-account-and-serializer balance)
+ (define (withdraw amount)
+ (if (>= balance amount)
+ (begin (set! balance (- balance amount))
+ balance)
+ "Insufficient funds"))
+ (define (deposit amount)
+ (set! balance (+ balance amount))
+ balance)
+ (let ((balance-serializer (make-serializer)))
+ (define (dispatch m)
+ (cond ((eq? m 'withdraw) (balance-serializer withdraw))
+ ((eq? m 'deposit) (balance-serializer deposit))
+ ((eq? m 'balance) balance)
+ ((eq? m 'serializer) balance-serializer)
+ (else (error "Unknown request -- MAKE-ACCOUNT"
+ m))))
+ dispatch))
+
+;; Then deposits are handled as with the original make-account:
+
+(define (deposit account amount)
+ ((account 'deposit) amount))
+
+;; Explain what is wrong with Louis's reasoning. In particular, consider what happens when serialized-exchange is called.
+
+(define (exchange account1 account2)
+ (let ((difference (- (account1 'balance)
+ (account2 'balance))))
+ ((account1 'withdraw) difference)
+ ((account2 'deposit) difference)))
+
+(define (serialized-exchange account1 account2)
+ (let ((serializer1 (account1 'serializer))
+ (serializer2 (account2 'serializer)))
+ ((serializer1 (serializer2 exchange))
+ account1
+ account2)))
+
+;; the mutex for serializer1 and serializer2 will be grabbed when this procedure is applied to account1 and account2:
+
+;; (serializer1 (serializer2 exchange))
+
+;; However, once inside the body of the exchange procedure, we need to apply the withdraw procedure for account1. This will cause the withdraw procedure to attempt to acquire the mutex from serializer1. But, because the mutex has already been acquired (and will not be released), the withdraw procedure will wait forever. Deadlock results.
blob - /dev/null
blob + 2aba523fd09ccc53b4b2bc69182892b6d71c3cec (mode 644)
--- /dev/null
+++ ex3-45.scm~
+
+
+Exercise 3.45. Louis Reasoner thinks our bank-account system is unnecessarily complex and error-prone now that deposits and withdrawals aren't automatically serialized. He suggests that make-account-and-serializer should have exported the serializer (for use by such procedures as serialized-exchange) in addition to (rather than instead of) using it to serialize accounts and deposits as make-account did. He proposes to redefine accounts as follows:
+
+(define (make-account-and-serializer balance)
+ (define (withdraw amount)
+ (if (>= balance amount)
+ (begin (set! balance (- balance amount))
+ balance)
+ "Insufficient funds"))
+ (define (deposit amount)
+ (set! balance (+ balance amount))
+ balance)
+ (let ((balance-serializer (make-serializer)))
+ (define (dispatch m)
+ (cond ((eq? m 'withdraw) (balance-serializer withdraw))
+ ((eq? m 'deposit) (balance-serializer deposit))
+ ((eq? m 'balance) balance)
+ ((eq? m 'serializer) balance-serializer)
+ (else (error "Unknown request -- MAKE-ACCOUNT"
+ m))))
+ dispatch))
+
+Then deposits are handled as with the original make-account:
+
+(define (deposit account amount)
+ ((account 'deposit) amount))
+
+Explain what is wrong with Louis's reasoning. In particular, consider what happens when serialized-exchange is called.
blob - /dev/null
blob + 170f8e2cd5cf3a29a9e4336244deaf58de27ea7b (mode 644)
--- /dev/null
+++ ex3-46.scm
+(define (make-serializer)
+ (let ((mutex (make-mutex)))
+ (lambda (p)
+ (define (serialized-p . args)
+ (mutex 'acquire)
+ (let ((val (apply p args)))
+ (mutex 'release)
+ val))
+ serialized-p)))
+
+(define (make-mutex)
+ (let ((cell (list false)))
+ (define (the-mutex m)
+ (cond ((eq? m 'acquire) (if (test-and-set! cell)
+ (the-mutex 'acquire)))
+ ((eq? m 'release) (clear! cell))))
+ the-mutex))
+
+(define (clear! cell)
+ (set-car! cell false))
+;; (define (test-and-set! cell)
+;; (if (car cell)
+;; true
+;; (begin (set-car! cell true)
+;; false)))
+(define (test-and-set! cell)
+ (without-interrupts
+ (lambda ()
+ (if (car cell)
+ true
+ (begin (set-car! cell true)
+ false)))))
+
+;; Exercise 3.46. Suppose that we implement test-and-set! using an ordinary procedure as shown in the text, without attempting to make the operation atomic. Draw a timing diagram like the one in figure 3.29 to demonstrate how the mutex implementation can fail by allowing two processes to acquire the mutex at the same time.
+
+;; The same mutex might be acquired at the same time by two different processes. For example, both may check (car cell) right after the other. It appears to both processes as though the mutex were free to be acquired, so both set the cell to true and think that they have exclusive access tothe mutex.
blob - /dev/null
blob + 7ce0e2642e9b72f5ada3370a1585b0b3edb96be9 (mode 644)
--- /dev/null
+++ ex3-46.scm~
+(define (make-serializer)
+ (let ((mutex (make-mutex)))
+ (lambda (p)
+ (define (serialized-p . args)
+ (mutex 'acqure)
+ (let ((val (apply p args)))
+ (mutex 'release)
+ val))
+ serialized-p)))
+
+(define (make-mutex)
+ (let ((cell (list false)))
+ (define (the-mutex m)
+ (cond ((eq? m 'acquire)
+ (if (test-and-set! cell)
+ (the-mutex 'acquire)))
+ ((eq? m 'release) (clear! cell))))
+ the-mutex))
+(define (clear! cell)
+ (set-car! cell false))
+(define (test-and-set! cell)
+ (if (car cell)
+ true
+ (begin (set-car! cell true)
+ false)))
blob - /dev/null
blob + 8c0b989b6611100d8b51b69e9855b235a1bf970f (mode 644)
--- /dev/null
+++ ex3-47-2.scm
+(define (make-semaphore-mtx maximal)
+ (let ((count maximal)
+ (mutex (make-mutex)))
+ (define (the-sema m)
+ (cond ((eq? m 'release)
+ (mutex 'acquire)
+ (unless (= count maximal)
+ (set! count (+ 1 count)))
+ (mutex 'release))
+ ((eq? m 'acquire)
+ (mutex 'acquire)
+ (cond ((> count 0)
+ (set! count (- count 1))
+ (mutex 'release))
+ (else
+ (mutex 'release)
+ (the-sema 'acquire))))
+ (else
+ (error "Unknown request -- " m))))
+ the-sema))
+
+
+
+(define (loop-test-and-set! cell)
+ (if (test-and-set! cell)
+ (loop-test-and-set! cell)
+ '()))
+
+(define (make-semaphore-ts maximal)
+ (let ((count maximal)
+ (guard (cons #f '())))
+ (define (the-sema m)
+ (cond ((eq? m 'release)
+ (loop-test-and-set! guard)
+ (unless (= count maximal)
+ (set! count (+ 1 count)))
+ (clear! guard))
+ ((eq? m 'acquire)
+ (cond (loop-test-and-set! guard)
+ ((> count 0)
+ (set! count (- count 1))
+ (clear! guard))
+ (else
+ (clear! guard)
+ (the-sema 'acquire))))
+ (else
+ (error "Unknown request -- " m))))
+ the-sema))
blob - /dev/null
blob + 03c29460d9aff707b71aa5e69ec6baa80a8bf1df (mode 644)
--- /dev/null
+++ ex3-47-2.scm~
+(define (make-semaphore-mtx maximal)
+ (let ((count maximal)
+ (mutex (make-mutex)))
+ (define (the-sema m)
+ (cond ((eq? m 'release)
+ (mutex 'acquire)
+ (unless (= count maximal)
+ (set! count (+ 1 count)))
+ (mutex 'release))
+ ((eq? m 'acquire)
+ (mutex 'acquire)
+ (cond ((> count 0)
+ (set! count (- count 1))
+ (mutex 'release))
+ (else
+ (mutex 'release)
+ (the-sema 'acquire))))
+ (else
+ (error "Unknown request -- " m))))
+ the-sema))
blob - /dev/null
blob + 9f55f66eacac4887a8b9afda4ea1db2e47e1e188 (mode 644)
--- /dev/null
+++ ex3-47.scm
+(define (make-serializer)
+ (let ((mutex (make-mutex)))
+ (lambda (p)
+ (define (serialized-p . args)
+ (mutex 'acquire)
+ (let ((val (apply p args)))
+ (mutex 'release)
+ val))
+ serialized-p)))
+
+(define (make-mutex)
+ (let ((cell (list false)))
+ (define (the-mutex m)
+ (cond ((eq? m 'acquire) (if (test-and-set! cell)
+ (the-mutex 'acquire)))
+ ((eq? m 'release) (clear! cell))))
+ the-mutex))
+
+(define (clear! cell)
+ (set-car! cell false))
+;; (define (test-and-set! cell)
+;; (if (car cell)
+;; true
+;; (begin (set-car! cell true)
+;; false)))
+(define (test-and-set! cell)
+ (without-interrupts
+ (lambda ()
+ (if (car cell)
+ true
+ (begin (set-car! cell true)
+ false)))))
+
+;; Exercise 3.47. A semaphore (of size n) is a generalization of a mutex. Like a mutex, a semaphore supports acquire and release operations, but it is more general in that up to n processes can acquire it concurrently. Additional processes that attempt to acquire the semaphore must wait for release operations. Give implementations of semaphores
+
+;; a. in terms of mutexes
+
+;; b. in terms of atomic test-and-set! operations.
+
+(define (make-semaphore n)
+ (let ((mutex (make-mutex)))
+ (define (the-semaphore m)
+ (cond ((eq? m 'acquire)
+ (mutex 'acquire)
+ (if (> n 0)
+ (begin (set! n (- n 1))
+ (mutex 'release))
+ (begin (mutex 'release)
+ (the-semaphore 'acquire))))
+ ((eq? m 'release)
+ (mutex 'acquire)
+ (set! n (+ n 1))
+ (mutex 'release))))
+ the-semaphore))
+
+(define (make-semaphore n)
+ (let ((cell (list false)))
+ (define (clear! cell)
+ (set-car! cell false))
+ (define (the-semaphore m)
+ (cond ((eq? m 'acquire)
+ (if (test-and-set! cell)
+ (the-semaphore 'acquire)
+ (if (> n 0)
+ (begin (set! n (- n 1))
+ (clear! cell))
+ (begin (clear! cell)
+ (the-semaphore 'acquire)))))
+ ((eq? m 'release)
+ (if (test-and-set! cell)
+ (the-semaphore 'release)
+ (begin (set! n (+ n 1))
+ (clear! cell))))))
+ the-semaphore))
blob - /dev/null
blob + 170f8e2cd5cf3a29a9e4336244deaf58de27ea7b (mode 644)
--- /dev/null
+++ ex3-47.scm~
+(define (make-serializer)
+ (let ((mutex (make-mutex)))
+ (lambda (p)
+ (define (serialized-p . args)
+ (mutex 'acquire)
+ (let ((val (apply p args)))
+ (mutex 'release)
+ val))
+ serialized-p)))
+
+(define (make-mutex)
+ (let ((cell (list false)))
+ (define (the-mutex m)
+ (cond ((eq? m 'acquire) (if (test-and-set! cell)
+ (the-mutex 'acquire)))
+ ((eq? m 'release) (clear! cell))))
+ the-mutex))
+
+(define (clear! cell)
+ (set-car! cell false))
+;; (define (test-and-set! cell)
+;; (if (car cell)
+;; true
+;; (begin (set-car! cell true)
+;; false)))
+(define (test-and-set! cell)
+ (without-interrupts
+ (lambda ()
+ (if (car cell)
+ true
+ (begin (set-car! cell true)
+ false)))))
+
+;; Exercise 3.46. Suppose that we implement test-and-set! using an ordinary procedure as shown in the text, without attempting to make the operation atomic. Draw a timing diagram like the one in figure 3.29 to demonstrate how the mutex implementation can fail by allowing two processes to acquire the mutex at the same time.
+
+;; The same mutex might be acquired at the same time by two different processes. For example, both may check (car cell) right after the other. It appears to both processes as though the mutex were free to be acquired, so both set the cell to true and think that they have exclusive access tothe mutex.
blob - /dev/null
blob + c0f7a6af8d38bd2cf1765fa0313b2f4067f9cd59 (mode 644)
--- /dev/null
+++ ex3-48.scm
+(define (make-serializer)
+ (let ((mutex (make-mutex)))
+ (lambda (p)
+ (define (serialized-p . args)
+ (mutex 'acquire)
+ (let ((val (apply p args)))
+ (mutex 'release)
+ val))
+ serialized-p)))
+
+(define (make-mutex)
+ (let ((cell (list false)))
+ (define (the-mutex m)
+ (cond ((eq? m 'acquire) (if (test-and-set! cell)
+ (the-mutex 'acquire)))
+ ((eq? m 'release) (clear! cell))))
+ the-mutex))
+
+(define (clear! cell)
+ (set-car! cell false))
+;; (define (test-and-set! cell)
+;; (if (car cell)
+;; true
+;; (begin (set-car! cell true)
+;; false)))
+(define (test-and-set! cell)
+ (without-interrupts
+ (lambda ()
+ (if (car cell)
+ true
+ (begin (set-car! cell true)
+ false)))))
+
+;; Exercise 3.47. A semaphore (of size n) is a generalization of a mutex. Like a mutex, a semaphore supports acquire and release operations, but it is more general in that up to n processes can acquire it concurrently. Additional processes that attempt to acquire the semaphore must wait for release operations. Give implementations of semaphores
+
+;; a. in terms of mutexes
+
+;; b. in terms of atomic test-and-set! operations.
+
+(define (make-semaphore n)
+ (let ((mutex (make-mutex)))
+ (define (the-semaphore m)
+ (cond ((eq? m 'acquire)
+ (mutex 'acquire)
+ (if (> n 0)
+ (begin (set! n (- n 1))
+ (mutex 'release))
+ (begin (mutex 'release)
+ (the-semaphore 'acquire))))
+ ((eq? m 'release)
+ (mutex 'acquire)
+ (set! n (+ n 1))
+ (mutex 'release))))
+ the-semaphore))
+
+(define (make-semaphore n)
+ (let ((cell (list false)))
+ (define (clear! cell)
+ (set-car! cell false))
+ (define (the-semaphore m)
+ (cond ((eq? m 'acquire)
+ (if (test-and-set! cell)
+ (the-semaphore 'acquire)
+ (if (> n 0)
+ (begin (set! n (- n 1))
+ (clear! cell))
+ (begin (clear! cell)
+ (the-semaphore 'acquire)))))
+ ((eq? m 'release)
+ (if (test-and-set! cell)
+ (the-semaphore 'release)
+ (begin (set! n (+ n 1))
+ (clear! cell))))))
+ the-semaphore))
+
+;; Exercise 3.48. Explain in detail why the deadlock-avoidance method described above, (i.e., the accounts are numbered, and each process attempts to acquire the smaller-numbered account first) avoids deadlock in the exchange problem. Rewrite serialized-exchange to incorporate this idea. (You will also need to modify make-account so that each account is created with a number, which can be accessed by sending an appropriate message.)
+
+;; The mutex for the account with the smaller number will always be acquired first. So, if two processes need to process the same two accounts, only one mutex for the lower-numbered account will be acquired successfully. So, only one process will obtain the first mutex, and that process will then proceed to obtain the other mutex.
+
+(define (serialized-exchange account1 account2)
+ (let ((serializer1 (account1 'serializer))
+ (serializer2 (account2 'serializer))
+ (num1 (account1 'number))
+ (num2 (account2 'number)))
+ (cond ((< num1 num2)
+ ((serializer1 (serializer2 exchange))
+ account1
+ account2))
+ ((> num1 num2)
+ ((serializer2 (serializer1 exchange))
+ account1 account2))
+ (else (error "Identical accounts" num1 num2)))))
blob - /dev/null
blob + 9f55f66eacac4887a8b9afda4ea1db2e47e1e188 (mode 644)
--- /dev/null
+++ ex3-48.scm~
+(define (make-serializer)
+ (let ((mutex (make-mutex)))
+ (lambda (p)
+ (define (serialized-p . args)
+ (mutex 'acquire)
+ (let ((val (apply p args)))
+ (mutex 'release)
+ val))
+ serialized-p)))
+
+(define (make-mutex)
+ (let ((cell (list false)))
+ (define (the-mutex m)
+ (cond ((eq? m 'acquire) (if (test-and-set! cell)
+ (the-mutex 'acquire)))
+ ((eq? m 'release) (clear! cell))))
+ the-mutex))
+
+(define (clear! cell)
+ (set-car! cell false))
+;; (define (test-and-set! cell)
+;; (if (car cell)
+;; true
+;; (begin (set-car! cell true)
+;; false)))
+(define (test-and-set! cell)
+ (without-interrupts
+ (lambda ()
+ (if (car cell)
+ true
+ (begin (set-car! cell true)
+ false)))))
+
+;; Exercise 3.47. A semaphore (of size n) is a generalization of a mutex. Like a mutex, a semaphore supports acquire and release operations, but it is more general in that up to n processes can acquire it concurrently. Additional processes that attempt to acquire the semaphore must wait for release operations. Give implementations of semaphores
+
+;; a. in terms of mutexes
+
+;; b. in terms of atomic test-and-set! operations.
+
+(define (make-semaphore n)
+ (let ((mutex (make-mutex)))
+ (define (the-semaphore m)
+ (cond ((eq? m 'acquire)
+ (mutex 'acquire)
+ (if (> n 0)
+ (begin (set! n (- n 1))
+ (mutex 'release))
+ (begin (mutex 'release)
+ (the-semaphore 'acquire))))
+ ((eq? m 'release)
+ (mutex 'acquire)
+ (set! n (+ n 1))
+ (mutex 'release))))
+ the-semaphore))
+
+(define (make-semaphore n)
+ (let ((cell (list false)))
+ (define (clear! cell)
+ (set-car! cell false))
+ (define (the-semaphore m)
+ (cond ((eq? m 'acquire)
+ (if (test-and-set! cell)
+ (the-semaphore 'acquire)
+ (if (> n 0)
+ (begin (set! n (- n 1))
+ (clear! cell))
+ (begin (clear! cell)
+ (the-semaphore 'acquire)))))
+ ((eq? m 'release)
+ (if (test-and-set! cell)
+ (the-semaphore 'release)
+ (begin (set! n (+ n 1))
+ (clear! cell))))))
+ the-semaphore))
blob - /dev/null
blob + a46e7959927af593f05f3d10c8b7e5f9f3c87eef (mode 644)
--- /dev/null
+++ ex3-49.scm
+(define (make-serializer)
+ (let ((mutex (make-mutex)))
+ (lambda (p)
+ (define (serialized-p . args)
+ (mutex 'acquire)
+ (let ((val (apply p args)))
+ (mutex 'release)
+ val))
+ serialized-p)))
+
+(define (make-mutex)
+ (let ((cell (list false)))
+ (define (the-mutex m)
+ (cond ((eq? m 'acquire) (if (test-and-set! cell)
+ (the-mutex 'acquire)))
+ ((eq? m 'release) (clear! cell))))
+ the-mutex))
+
+(define (clear! cell)
+ (set-car! cell false))
+;; (define (test-and-set! cell)
+;; (if (car cell)
+;; true
+;; (begin (set-car! cell true)
+;; false)))
+(define (test-and-set! cell)
+ (without-interrupts
+ (lambda ()
+ (if (car cell)
+ true
+ (begin (set-car! cell true)
+ false)))))
+
+;; Exercise 3.47. A semaphore (of size n) is a generalization of a mutex. Like a mutex, a semaphore supports acquire and release operations, but it is more general in that up to n processes can acquire it concurrently. Additional processes that attempt to acquire the semaphore must wait for release operations. Give implementations of semaphores
+
+;; a. in terms of mutexes
+
+;; b. in terms of atomic test-and-set! operations.
+
+(define (make-semaphore n)
+ (let ((mutex (make-mutex)))
+ (define (the-semaphore m)
+ (cond ((eq? m 'acquire)
+ (mutex 'acquire)
+ (if (> n 0)
+ (begin (set! n (- n 1))
+ (mutex 'release))
+ (begin (mutex 'release)
+ (the-semaphore 'acquire))))
+ ((eq? m 'release)
+ (mutex 'acquire)
+ (set! n (+ n 1))
+ (mutex 'release))))
+ the-semaphore))
+
+(define (make-semaphore n)
+ (let ((cell (list false)))
+ (define (clear! cell)
+ (set-car! cell false))
+ (define (the-semaphore m)
+ (cond ((eq? m 'acquire)
+ (if (test-and-set! cell)
+ (the-semaphore 'acquire)
+ (if (> n 0)
+ (begin (set! n (- n 1))
+ (clear! cell))
+ (begin (clear! cell)
+ (the-semaphore 'acquire)))))
+ ((eq? m 'release)
+ (if (test-and-set! cell)
+ (the-semaphore 'release)
+ (begin (set! n (+ n 1))
+ (clear! cell))))))
+ the-semaphore))
+
+;; Exercise 3.48. Explain in detail why the deadlock-avoidance method described above, (i.e., the accounts are numbered, and each process attempts to acquire the smaller-numbered account first) avoids deadlock in the exchange problem. Rewrite serialized-exchange to incorporate this idea. (You will also need to modify make-account so that each account is created with a number, which can be accessed by sending an appropriate message.)
+
+;; The mutex for the account with the smaller number will always be acquired first. So, if two processes need to process the same two accounts, only one mutex for the lower-numbered account will be acquired successfully. So, only one process will obtain the first mutex, and that process will then proceed to obtain the other mutex.
+
+(define (serialized-exchange account1 account2)
+ (let ((serializer1 (account1 'serializer))
+ (serializer2 (account2 'serializer))
+ (num1 (account1 'number))
+ (num2 (account2 'number)))
+ (cond ((< num1 num2)
+ ((serializer1 (serializer2 exchange))
+ account1
+ account2))
+ ((> num1 num2)
+ ((serializer2 (serializer1 exchange))
+ account1 account2))
+ (else (error "Identical accounts" num1 num2)))))
+
+;; Exercise 3.49. Give a scenario where the deadlock-avoidance mechanism described above does not work. (Hint: In the exchange problem, each process knows in advance which accounts it will need to get access to. Consider a situation where a process must get access to some shared resources before it can know which additional shared resources it will require.)
+
+;; Maybe you want to transfer to an account but you need to ask the account for which account to transfer to.
blob - /dev/null
blob + c0f7a6af8d38bd2cf1765fa0313b2f4067f9cd59 (mode 644)
--- /dev/null
+++ ex3-49.scm~
+(define (make-serializer)
+ (let ((mutex (make-mutex)))
+ (lambda (p)
+ (define (serialized-p . args)
+ (mutex 'acquire)
+ (let ((val (apply p args)))
+ (mutex 'release)
+ val))
+ serialized-p)))
+
+(define (make-mutex)
+ (let ((cell (list false)))
+ (define (the-mutex m)
+ (cond ((eq? m 'acquire) (if (test-and-set! cell)
+ (the-mutex 'acquire)))
+ ((eq? m 'release) (clear! cell))))
+ the-mutex))
+
+(define (clear! cell)
+ (set-car! cell false))
+;; (define (test-and-set! cell)
+;; (if (car cell)
+;; true
+;; (begin (set-car! cell true)
+;; false)))
+(define (test-and-set! cell)
+ (without-interrupts
+ (lambda ()
+ (if (car cell)
+ true
+ (begin (set-car! cell true)
+ false)))))
+
+;; Exercise 3.47. A semaphore (of size n) is a generalization of a mutex. Like a mutex, a semaphore supports acquire and release operations, but it is more general in that up to n processes can acquire it concurrently. Additional processes that attempt to acquire the semaphore must wait for release operations. Give implementations of semaphores
+
+;; a. in terms of mutexes
+
+;; b. in terms of atomic test-and-set! operations.
+
+(define (make-semaphore n)
+ (let ((mutex (make-mutex)))
+ (define (the-semaphore m)
+ (cond ((eq? m 'acquire)
+ (mutex 'acquire)
+ (if (> n 0)
+ (begin (set! n (- n 1))
+ (mutex 'release))
+ (begin (mutex 'release)
+ (the-semaphore 'acquire))))
+ ((eq? m 'release)
+ (mutex 'acquire)
+ (set! n (+ n 1))
+ (mutex 'release))))
+ the-semaphore))
+
+(define (make-semaphore n)
+ (let ((cell (list false)))
+ (define (clear! cell)
+ (set-car! cell false))
+ (define (the-semaphore m)
+ (cond ((eq? m 'acquire)
+ (if (test-and-set! cell)
+ (the-semaphore 'acquire)
+ (if (> n 0)
+ (begin (set! n (- n 1))
+ (clear! cell))
+ (begin (clear! cell)
+ (the-semaphore 'acquire)))))
+ ((eq? m 'release)
+ (if (test-and-set! cell)
+ (the-semaphore 'release)
+ (begin (set! n (+ n 1))
+ (clear! cell))))))
+ the-semaphore))
+
+;; Exercise 3.48. Explain in detail why the deadlock-avoidance method described above, (i.e., the accounts are numbered, and each process attempts to acquire the smaller-numbered account first) avoids deadlock in the exchange problem. Rewrite serialized-exchange to incorporate this idea. (You will also need to modify make-account so that each account is created with a number, which can be accessed by sending an appropriate message.)
+
+;; The mutex for the account with the smaller number will always be acquired first. So, if two processes need to process the same two accounts, only one mutex for the lower-numbered account will be acquired successfully. So, only one process will obtain the first mutex, and that process will then proceed to obtain the other mutex.
+
+(define (serialized-exchange account1 account2)
+ (let ((serializer1 (account1 'serializer))
+ (serializer2 (account2 'serializer))
+ (num1 (account1 'number))
+ (num2 (account2 'number)))
+ (cond ((< num1 num2)
+ ((serializer1 (serializer2 exchange))
+ account1
+ account2))
+ ((> num1 num2)
+ ((serializer2 (serializer1 exchange))
+ account1 account2))
+ (else (error "Identical accounts" num1 num2)))))
blob - /dev/null
blob + c3c73a64eff044b5720a59fcba812c1879ba28d3 (mode 644)
--- /dev/null
+++ ex3-50-a.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc s)
+ (if (stream-null? s)
+ the-empty-stream
+ (cons-stream (proc (stream-car s))
+ (stream-map proc (stream-cdr s)))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+
+(define counting-numbers (integers-starting-from 1))
+(test-case (stream-car (stream-cdr (stream-cdr counting-numbers))) 3)
blob - /dev/null
blob + fcbe0cb73ffaeef99656e144a0a4dedd5f722d95 (mode 644)
--- /dev/null
+++ ex3-50.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc s)
+ (if (stream-null? s)
+ the-empty-stream
+ (cons-stream (proc (stream-car s))
+ (stream-map proc (stream-cdr s)))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 3.50. Complete the following definition, which generalizes stream-map to allow procedures that take multiple arguments, analogous to map in section 2.2.3, footnote 12.
+
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map
+ (cons proc (map stream-cdr argstreams))))))
+
+(define integers (integers-starting-from 1))
+(test-case (stream-car (stream-cdr (stream-cdr (stream-cdr (stream-map * integers integers))))) 16)
blob - /dev/null
blob + c3c73a64eff044b5720a59fcba812c1879ba28d3 (mode 644)
--- /dev/null
+++ ex3-50.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc s)
+ (if (stream-null? s)
+ the-empty-stream
+ (cons-stream (proc (stream-car s))
+ (stream-map proc (stream-cdr s)))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+
+(define counting-numbers (integers-starting-from 1))
+(test-case (stream-car (stream-cdr (stream-cdr counting-numbers))) 3)
blob - /dev/null
blob + b71237a8109f941a0b2ce3468a9eb05e58bc25aa (mode 644)
--- /dev/null
+++ ex3-51.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc s)
+ (if (stream-null? s)
+ the-empty-stream
+ (cons-stream (proc (stream-car s))
+ (stream-map proc (stream-cdr s)))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+ ;; Exercise 3.51. In order to take a closer look at delayed evaluation, we will use the following procedure, which simply returns its argument after printing it:
+
+(define (show x)
+ (display-line x)
+ x)
+
+;; What does the interpreter print in response to evaluating each expression in the following sequence?59
+
+(define x (stream-map show (stream-enumerate-interval 0 10)))
+;; 0
+(newline)
+(stream-ref x 5)
+;; 1->5
+(newline)
+(stream-ref x 7)
+;; 6->7
blob - /dev/null
blob + fcbe0cb73ffaeef99656e144a0a4dedd5f722d95 (mode 644)
--- /dev/null
+++ ex3-51.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc s)
+ (if (stream-null? s)
+ the-empty-stream
+ (cons-stream (proc (stream-car s))
+ (stream-map proc (stream-cdr s)))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 3.50. Complete the following definition, which generalizes stream-map to allow procedures that take multiple arguments, analogous to map in section 2.2.3, footnote 12.
+
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map
+ (cons proc (map stream-cdr argstreams))))))
+
+(define integers (integers-starting-from 1))
+(test-case (stream-car (stream-cdr (stream-cdr (stream-cdr (stream-map * integers integers))))) 16)
blob - /dev/null
blob + 897c0b327fdaa85e5ffdaa313b6aff620b9b1f84 (mode 644)
--- /dev/null
+++ ex3-52.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc s)
+ (if (stream-null? s)
+ the-empty-stream
+ (cons-stream (proc (stream-car s))
+ (stream-map proc (stream-cdr s)))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 3.52. Consider the sequence of expressions
+
+(define sum 0)
+(define (accum x)
+ (set! sum (+ x sum))
+ sum)
+(define seq (stream-map accum (stream-enumerate-interval 1 20)))
+(test-case sum 1)
+(define y (stream-filter even? seq))
+(test-case sum 6)
+(define z (stream-filter (lambda (x) (= (remainder x 5) 0))
+ seq))
+(test-case sum 10)
+(stream-ref y 7)
+;; 1 3 6 10 15 21 28 36 45 55 66 78 91 105 120 136
+(test-case sum 136)
+(display-stream z)
+;; 1 3 6 10 15 21 28 36 45 55 66 78 91 105 120 136 153 171 190 210
+(newline)
+(display '(10 15 45 55 105 120 190 210))
+
+;; What is the value of sum after each of the above expressions is evaluated? What is the printed response to evaluating the stream-ref and display-stream expressions? Would these responses differ if we had implemented (delay <exp>) simply as (lambda () <exp>) without using the optimization provided by memo-proc ? Explain.
+
+(define (memo-proc proc)
+ proc) ;; get rid of the optimization
+(define sum 0)
+(define (accum x)
+ (set! sum (+ x sum))
+ sum)
+(define seq (stream-map accum (stream-enumerate-interval 1 20)))
+(test-case sum 1)
+(define y (stream-filter even? seq))
+(test-case sum 6)
+(define z (stream-filter (lambda (x) (= (remainder x 5) 0))
+ seq))
+;; 1 8 11 15
+(test-case sum 15)
+(stream-ref y 7)
+;; y
+;; *6 19 *24 *30 37 45 *54 *64 75 87 *100 *114 129 145 *162
+(test-case sum 162)
+(display-stream z)
+;; *15 167 173 *180 188 197 207 218 *230 243 257 272 288 *305 323 342 362
+(newline)
+(display '(15 180 230 305))
+
blob - /dev/null
blob + 2d28958bb25ac141180b35b931d4dee6a24cf893 (mode 644)
--- /dev/null
+++ ex3-52.scm~
+
+Exercise 3.52. Consider the sequence of expressions
+
+(define sum 0)
+(define (accum x)
+ (set! sum (+ x sum))
+ sum)
+(define seq (stream-map accum (stream-enumerate-interval 1 20)))
+(define y (stream-filter even? seq))
+(define z (stream-filter (lambda (x) (= (remainder x 5) 0))
+ seq))
+(stream-ref y 7)
+(display-stream z)
+
+What is the value of sum after each of the above expressions is evaluated? What is the printed response to evaluating the stream-ref and display-stream expressions? Would these responses differ if we had implemented (delay <exp>) simply as (lambda () <exp>) without using the optimization provided by memo-proc ? Explain.
blob - /dev/null
blob + db92a5c6c04da33dd849765621e4bba25c6d4b9c (mode 644)
--- /dev/null
+++ ex3-53.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+;; (test-case (stream-ref primes 26) 103
+
+;; Exercise 3.53. Without running the program, describe the elements of the stream defined by
+
+(define s (cons-stream 1 (add-streams s s))))
+
+;; the powers of 2, just like double
blob - /dev/null
blob + 897c0b327fdaa85e5ffdaa313b6aff620b9b1f84 (mode 644)
--- /dev/null
+++ ex3-53.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc s)
+ (if (stream-null? s)
+ the-empty-stream
+ (cons-stream (proc (stream-car s))
+ (stream-map proc (stream-cdr s)))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+;; Exercise 3.52. Consider the sequence of expressions
+
+(define sum 0)
+(define (accum x)
+ (set! sum (+ x sum))
+ sum)
+(define seq (stream-map accum (stream-enumerate-interval 1 20)))
+(test-case sum 1)
+(define y (stream-filter even? seq))
+(test-case sum 6)
+(define z (stream-filter (lambda (x) (= (remainder x 5) 0))
+ seq))
+(test-case sum 10)
+(stream-ref y 7)
+;; 1 3 6 10 15 21 28 36 45 55 66 78 91 105 120 136
+(test-case sum 136)
+(display-stream z)
+;; 1 3 6 10 15 21 28 36 45 55 66 78 91 105 120 136 153 171 190 210
+(newline)
+(display '(10 15 45 55 105 120 190 210))
+
+;; What is the value of sum after each of the above expressions is evaluated? What is the printed response to evaluating the stream-ref and display-stream expressions? Would these responses differ if we had implemented (delay <exp>) simply as (lambda () <exp>) without using the optimization provided by memo-proc ? Explain.
+
+(define (memo-proc proc)
+ proc) ;; get rid of the optimization
+(define sum 0)
+(define (accum x)
+ (set! sum (+ x sum))
+ sum)
+(define seq (stream-map accum (stream-enumerate-interval 1 20)))
+(test-case sum 1)
+(define y (stream-filter even? seq))
+(test-case sum 6)
+(define z (stream-filter (lambda (x) (= (remainder x 5) 0))
+ seq))
+;; 1 8 11 15
+(test-case sum 15)
+(stream-ref y 7)
+;; y
+;; *6 19 *24 *30 37 45 *54 *64 75 87 *100 *114 129 145 *162
+(test-case sum 162)
+(display-stream z)
+;; *15 167 173 *180 188 197 207 218 *230 243 257 272 288 *305 323 342 362
+(newline)
+(display '(15 180 230 305))
+
blob - /dev/null
blob + 08b464c6b6520b65293743d925bf9d1aa296ebba (mode 644)
--- /dev/null
+++ ex3-54.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+;; (test-case (stream-ref primes 26) 103
+
+;; Exercise 3.54. Define a procedure mul-streams, analogous to add-streams, that produces the elementwise product of its two input streams. Use this together with the stream of integers to complete the following definition of the stream whose nth element (counting from 0) is n + 1 factorial:
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define factorials (cons-stream 1 (mul-streams factorials (stream-cdr integers))))
+
+(test-case (stream-ref factorials 9) 3628800)
blob - /dev/null
blob + db92a5c6c04da33dd849765621e4bba25c6d4b9c (mode 644)
--- /dev/null
+++ ex3-54.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+;; (test-case (stream-ref primes 26) 103
+
+;; Exercise 3.53. Without running the program, describe the elements of the stream defined by
+
+(define s (cons-stream 1 (add-streams s s))))
+
+;; the powers of 2, just like double
blob - /dev/null
blob + 45b412e8520bbde5508cd7985834216349478731 (mode 644)
--- /dev/null
+++ ex3-55.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+;; Exercise 3.55. Define a procedure partial-sums that takes as argument a stream S and returns the stream whose elements are S0, S0 + S1, S0 + S1 + S2, .... For example, (partial-sums integers) should be the stream 1, 3, 6, 10, 15, ....
+
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(test-case (stream-ref (partial-sums integers) 19) 210)
blob - /dev/null
blob + 08b464c6b6520b65293743d925bf9d1aa296ebba (mode 644)
--- /dev/null
+++ ex3-55.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+;; (test-case (stream-ref primes 26) 103
+
+;; Exercise 3.54. Define a procedure mul-streams, analogous to add-streams, that produces the elementwise product of its two input streams. Use this together with the stream of integers to complete the following definition of the stream whose nth element (counting from 0) is n + 1 factorial:
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define factorials (cons-stream 1 (mul-streams factorials (stream-cdr integers))))
+
+(test-case (stream-ref factorials 9) 3628800)
blob - /dev/null
blob + 845df4ede2c4d5fe199545ed5996134df3d9ad4f (mode 644)
--- /dev/null
+++ ex3-56.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+;; Exercise 3.56. A famous problem, first raised by R. Hamming, is to enumerate, in ascending order with no repetitions, all positive integers with no prime factors other than 2, 3, or 5. One obvious way to do this is to simply test each integer in turn to see whether it has any factors other than 2, 3, and 5. But this is very inefficient, since, as the integers get larger, fewer and fewer of them fit the requirement. As an alternative, let us call the required stream of numbers S and notice the following facts about it.
+
+;; S begins with 1.
+
+;; The elements of (scale-stream S 2) are also elements of S.
+
+;; The same is true for (scale-stream S 3) and (scale-stream 5 S).
+
+;; These are all the elements of S.
+
+;; Now all we have to do is combine elements from these sources. For this we define a procedure merge that combines two ordered streams into one ordered result stream, eliminating repetitions:
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+;; (define S (cons-stream 1 (merge <??> <??>)))
+
+;; Fill in the missing expressions in the places marked <??> above.
+
+(define S
+ (cons-stream
+ 1
+ (merge (scale-stream S 2)
+ (merge (scale-stream S 3)
+ (scale-stream S 5)))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(test-stream-list S '(1 2 3 4 5 6 8 9 10 12 15 16 18 20 24 25 27 30))
+
+
blob - /dev/null
blob + 45b412e8520bbde5508cd7985834216349478731 (mode 644)
--- /dev/null
+++ ex3-56.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+;; Exercise 3.55. Define a procedure partial-sums that takes as argument a stream S and returns the stream whose elements are S0, S0 + S1, S0 + S1 + S2, .... For example, (partial-sums integers) should be the stream 1, 3, 6, 10, 15, ....
+
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(test-case (stream-ref (partial-sums integers) 19) 210)
blob - /dev/null
blob + e6fc3b0f1c7661309da5ff228025255516691bc5 (mode 644)
--- /dev/null
+++ ex3-57.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+
+;; Exercise 3.57. How many additions are performed when we compute the nth Fibonacci number using the definition of fibs based on the add-streams procedure? Show that the number of additions would be exponentially greater if we had implemented (delay <exp>) simply as (lambda () <exp>), without using the optimization provided by the memo-proc procedure described in section 3.5.1.64
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+;; for call-by-need fibs, the number of additions performed
+;; 1: 0
+;; 2: 0
+;; 3: +1
+;; 4: +1
+;; to get the nth fib, we need to perform n-2 additions
+
+;; for call-by-name fibs, the number of additions performed:
+;; 1: 0
+;; 2: 0
+;; 3: +1 = 1
+;; 4: +(1)+1 = 3 ;; 2nd number is running total
+;; 5: +(1+3)+1 = 8
+;; 6: +(3+8)+1 = 20
+
blob - /dev/null
blob + 845df4ede2c4d5fe199545ed5996134df3d9ad4f (mode 644)
--- /dev/null
+++ ex3-57.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+;; Exercise 3.56. A famous problem, first raised by R. Hamming, is to enumerate, in ascending order with no repetitions, all positive integers with no prime factors other than 2, 3, or 5. One obvious way to do this is to simply test each integer in turn to see whether it has any factors other than 2, 3, and 5. But this is very inefficient, since, as the integers get larger, fewer and fewer of them fit the requirement. As an alternative, let us call the required stream of numbers S and notice the following facts about it.
+
+;; S begins with 1.
+
+;; The elements of (scale-stream S 2) are also elements of S.
+
+;; The same is true for (scale-stream S 3) and (scale-stream 5 S).
+
+;; These are all the elements of S.
+
+;; Now all we have to do is combine elements from these sources. For this we define a procedure merge that combines two ordered streams into one ordered result stream, eliminating repetitions:
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+;; (define S (cons-stream 1 (merge <??> <??>)))
+
+;; Fill in the missing expressions in the places marked <??> above.
+
+(define S
+ (cons-stream
+ 1
+ (merge (scale-stream S 2)
+ (merge (scale-stream S 3)
+ (scale-stream S 5)))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(test-stream-list S '(1 2 3 4 5 6 8 9 10 12 15 16 18 20 24 25 27 30))
+
+
blob - /dev/null
blob + bf016947ac478cef28bcee44d9c875e3a326d8c7 (mode 644)
--- /dev/null
+++ ex3-58.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+ ;; Exercise 3.58. Give an interpretation of the stream computed by the following procedure:
+
+(define (expand num den radix)
+ (cons-stream
+ (quotient (* num radix) den)
+ (expand (remainder (* num radix) den) den radix)))
+
+;; (Quotient is a primitive that returns the integer quotient of two integers.) What are the successive elements produced by (expand 1 7 10) ? What is produced by (expand 3 8 10) ?
+
+;; num/den expressed as a decimal(? not sure what it's called when not in base 10) in base radix
+;; the elements of the stream are the digits
+
+(newline)
+(test-stream-list (expand 1 7 10) '(1 4 2 8 5 7 1 4 2 8))
+(test-stream-list (expand 3 8 10) '(3 7 5 0 0 0 0))
blob - /dev/null
blob + e6fc3b0f1c7661309da5ff228025255516691bc5 (mode 644)
--- /dev/null
+++ ex3-58.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+
+;; Exercise 3.57. How many additions are performed when we compute the nth Fibonacci number using the definition of fibs based on the add-streams procedure? Show that the number of additions would be exponentially greater if we had implemented (delay <exp>) simply as (lambda () <exp>), without using the optimization provided by the memo-proc procedure described in section 3.5.1.64
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+;; for call-by-need fibs, the number of additions performed
+;; 1: 0
+;; 2: 0
+;; 3: +1
+;; 4: +1
+;; to get the nth fib, we need to perform n-2 additions
+
+;; for call-by-name fibs, the number of additions performed:
+;; 1: 0
+;; 2: 0
+;; 3: +1 = 1
+;; 4: +(1)+1 = 3 ;; 2nd number is running total
+;; 5: +(1+3)+1 = 8
+;; 6: +(3+8)+1 = 20
+
blob - /dev/null
blob + 95da31a029589ac684ab6d1f8c311cc90053906b (mode 644)
--- /dev/null
+++ ex3-59.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+;; Exercise 3.59. In section 2.5.3 we saw how to implement a polynomial arithmetic system representing polynomials as lists of terms. In a similar way, we can work with power series, such as
+
+;; represented as infinite streams. We will represent the series a0 + a1 x + a2 x2 + a3 x3 + ··· as the stream whose elements are the coefficients a0, a1, a2, a3, ....
+
+;; a. The integral of the series a0 + a1 x + a2 x2 + a3 x3 + ··· is the series
+
+;; where c is any constant. Define a procedure integrate-series that takes as input a stream a0, a1, a2, ... representing a power series and returns the stream a0, (1/2)a1, (1/3)a2, ... of coefficients of the non-constant terms of the integral of the series. (Since the result has no constant term, it doesn't represent a power series; when we use integrate-series, we will cons on the appropriate constant.)
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+;; b. The function x ex is its own derivative. This implies that ex and the integral of ex are the same series, except for the constant term, which is e0 = 1. Accordingly, we can generate the series for ex as
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+;; Show how to generate the series for sine and cosine, starting from the facts that the derivative of sine is cosine and the derivative of cosine is the negative of sine:
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+ Exercise 3.60. With power series represented as streams of coefficients as in exercise 3.59, adding series is implemented by add-streams. Complete the definition of the following procedure for multiplying series:
+
+(define (mul-series s1 s2)
+ (cons-stream <??> (add-streams <??> <??>)))
+
+You can test your procedure by verifying that sin2 x + cos2 x = 1, using the series from exercise 3.59.
blob - /dev/null
blob + bf016947ac478cef28bcee44d9c875e3a326d8c7 (mode 644)
--- /dev/null
+++ ex3-59.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+ ;; Exercise 3.58. Give an interpretation of the stream computed by the following procedure:
+
+(define (expand num den radix)
+ (cons-stream
+ (quotient (* num radix) den)
+ (expand (remainder (* num radix) den) den radix)))
+
+;; (Quotient is a primitive that returns the integer quotient of two integers.) What are the successive elements produced by (expand 1 7 10) ? What is produced by (expand 3 8 10) ?
+
+;; num/den expressed as a decimal(? not sure what it's called when not in base 10) in base radix
+;; the elements of the stream are the digits
+
+(newline)
+(test-stream-list (expand 1 7 10) '(1 4 2 8 5 7 1 4 2 8))
+(test-stream-list (expand 3 8 10) '(3 7 5 0 0 0 0))
blob - /dev/null
blob + dc71ea11763e32de55264dbcbd88bbec13b8e3ba (mode 644)
--- /dev/null
+++ ex3-60.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+;; Exercise 3.60. With power series represented as streams of coefficients as in exercise 3.59, adding series is implemented by add-streams. Complete the definition of the following procedure for multiplying series:
+
+(define (mul-series s1 s2)
+ (cons-stream <??> (add-streams <??> <??>)))
+
+;; You can test your procedure by verifying that sin2 x + cos2 x = 1, using the series from exercise 3.59.
+
+;; a0 a1 a2 a3 a4 a5
+;; b0 b1 b2 b3 b4 b5
+
+;; a0b0
+;; a0b1 + a1b0
+;; a0b2 + a1b1 + a2b0
+;; a0b3 + a1b2 + a2b1 + a3b0
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(newline)
+(test-stream-list
+ (add-streams (mul-series sine-series sine-series)
+ (mul-series cosine-series cosine-series))
+ '(1 0 0 0 0 0 0 0))
blob - /dev/null
blob + 95da31a029589ac684ab6d1f8c311cc90053906b (mode 644)
--- /dev/null
+++ ex3-60.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+;; Exercise 3.59. In section 2.5.3 we saw how to implement a polynomial arithmetic system representing polynomials as lists of terms. In a similar way, we can work with power series, such as
+
+;; represented as infinite streams. We will represent the series a0 + a1 x + a2 x2 + a3 x3 + ··· as the stream whose elements are the coefficients a0, a1, a2, a3, ....
+
+;; a. The integral of the series a0 + a1 x + a2 x2 + a3 x3 + ··· is the series
+
+;; where c is any constant. Define a procedure integrate-series that takes as input a stream a0, a1, a2, ... representing a power series and returns the stream a0, (1/2)a1, (1/3)a2, ... of coefficients of the non-constant terms of the integral of the series. (Since the result has no constant term, it doesn't represent a power series; when we use integrate-series, we will cons on the appropriate constant.)
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+;; b. The function x ex is its own derivative. This implies that ex and the integral of ex are the same series, except for the constant term, which is e0 = 1. Accordingly, we can generate the series for ex as
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+;; Show how to generate the series for sine and cosine, starting from the facts that the derivative of sine is cosine and the derivative of cosine is the negative of sine:
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+ Exercise 3.60. With power series represented as streams of coefficients as in exercise 3.59, adding series is implemented by add-streams. Complete the definition of the following procedure for multiplying series:
+
+(define (mul-series s1 s2)
+ (cons-stream <??> (add-streams <??> <??>)))
+
+You can test your procedure by verifying that sin2 x + cos2 x = 1, using the series from exercise 3.59.
blob - /dev/null
blob + 48e3620b5a5a7c409740114dc9185acceb7ee6ba (mode 644)
--- /dev/null
+++ ex3-61.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+;; Exercise 3.61. Let S be a power series (exercise 3.59) whose constant term is 1. Suppose we want to find the power series 1/S, that is, the series X such that S · X = 1. Write S = 1 + SR where SR is the part of S after the constant term. Then we can solve for X as follows:
+
+;; X = 1 - SR·X
+
+;; In other words, X is the power series whose constant term is 1 and whose higher-order terms are given by the negative of SR times X. Use this idea to write a procedure invert-unit-series that computes 1/S for a power series S with constant term 1. You will need to use mul-series from exercise 3.60.
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
blob - /dev/null
blob + dc71ea11763e32de55264dbcbd88bbec13b8e3ba (mode 644)
--- /dev/null
+++ ex3-61.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+;; Exercise 3.60. With power series represented as streams of coefficients as in exercise 3.59, adding series is implemented by add-streams. Complete the definition of the following procedure for multiplying series:
+
+(define (mul-series s1 s2)
+ (cons-stream <??> (add-streams <??> <??>)))
+
+;; You can test your procedure by verifying that sin2 x + cos2 x = 1, using the series from exercise 3.59.
+
+;; a0 a1 a2 a3 a4 a5
+;; b0 b1 b2 b3 b4 b5
+
+;; a0b0
+;; a0b1 + a1b0
+;; a0b2 + a1b1 + a2b0
+;; a0b3 + a1b2 + a2b1 + a3b0
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(newline)
+(test-stream-list
+ (add-streams (mul-series sine-series sine-series)
+ (mul-series cosine-series cosine-series))
+ '(1 0 0 0 0 0 0 0))
blob - /dev/null
blob + c48836e627937a4b4d3354c59213a1472f07978b (mode 644)
--- /dev/null
+++ ex3-62.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+;; Exercise 3.61. Let S be a power series (exercise 3.59) whose constant term is 1. Suppose we want to find the power series 1/S, that is, the series X such that S · X = 1. Write S = 1 + SR where SR is the part of S after the constant term. Then we can solve for X as follows:
+
+;; X = 1 - SR·X
+
+;; In other words, X is the power series whose constant term is 1 and whose higher-order terms are given by the negative of SR times X. Use this idea to write a procedure invert-unit-series that computes 1/S for a power series S with constant term 1. You will need to use mul-series from exercise 3.60.
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+;; Exercise 3.62. Use the results of exercises 3.60 and 3.61 to define a procedure div-series that divides two power series. Div-series should work for any two series, provided that the denominator series begins with a nonzero constant term. (If the denominator has a zero constant term, then div-series should signal an error.) Show how to use div-series together with the result of exercise 3.59 to generate the power series for tangent.
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+(define tangent-series (div-series sine-series cosine-series))
+(test-stream-list
+ tangent-series
+ '(0 1 0 1/3 0 2/15 0 17/315 0 62/2835))
blob - /dev/null
blob + 48e3620b5a5a7c409740114dc9185acceb7ee6ba (mode 644)
--- /dev/null
+++ ex3-62.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+;; Exercise 3.61. Let S be a power series (exercise 3.59) whose constant term is 1. Suppose we want to find the power series 1/S, that is, the series X such that S · X = 1. Write S = 1 + SR where SR is the part of S after the constant term. Then we can solve for X as follows:
+
+;; X = 1 - SR·X
+
+;; In other words, X is the power series whose constant term is 1 and whose higher-order terms are given by the negative of SR times X. Use this idea to write a procedure invert-unit-series that computes 1/S for a power series S with constant term 1. You will need to use mul-series from exercise 3.60.
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
blob - /dev/null
blob + cf9ab4b7563cc28ab391ad0cdf74ad0ce9ff90c0 (mode 644)
--- /dev/null
+++ ex3-63.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+;; (test-stream-list (stream-map exact->inexact (sqrt-stream 2))
+;; '(1 1.5 1.4166 1.4142156 1.41421356))
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+;; (test-stream-list (stream-map exact->inexact pi-stream)
+;; '(4 2.6667 3.4667 2.8952 3.3397))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+;; (test-stream-list (stream-map exact->inexact (euler-transform pi-stream))
+;; '(3.1667 3.1333 3.1452 3.1397 3.1427))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+;; (test-stream-list (stream-map exact->inexact (stream-map stream-car (make-tableau euler-transform pi-stream)))
+;; '(4 3.1667 3.1421 3.1459935 3.1415927140 3.145926539752927))
+
+;; Exercise 3.63. Louis Reasoner asks why the sqrt-stream procedure was not written in the following more straightforward way, without the local variable guesses:
+
+(define (sqrt-stream x)
+ (cons-stream 1.0
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ (sqrt-stream x))))
+
+;; Alyssa P. Hacker replies that this version of the procedure is considerably less efficient because it performs redundant computation. Explain Alyssa's answer. Would the two versions still differ in efficiency if our implementation of delay used only (lambda () <exp>) without using the optimization provided by memo-proc (section 3.5.1)?
+
+;; by defining guesses, the procedure is able to take advantage of the fact that the previous terms in the stream have been calculated before. When mapping guesses, the delayed objects in the stream which have already been evaluated can simply return their memoized values. Without guesses, each new iteration would require the computation (from scratch) of each previous iteration.
+
+;; without the optimization, the two implementations would be equally inefficient
blob - /dev/null
blob + c48836e627937a4b4d3354c59213a1472f07978b (mode 644)
--- /dev/null
+++ ex3-63.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+;; Exercise 3.61. Let S be a power series (exercise 3.59) whose constant term is 1. Suppose we want to find the power series 1/S, that is, the series X such that S · X = 1. Write S = 1 + SR where SR is the part of S after the constant term. Then we can solve for X as follows:
+
+;; X = 1 - SR·X
+
+;; In other words, X is the power series whose constant term is 1 and whose higher-order terms are given by the negative of SR times X. Use this idea to write a procedure invert-unit-series that computes 1/S for a power series S with constant term 1. You will need to use mul-series from exercise 3.60.
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+;; Exercise 3.62. Use the results of exercises 3.60 and 3.61 to define a procedure div-series that divides two power series. Div-series should work for any two series, provided that the denominator series begins with a nonzero constant term. (If the denominator has a zero constant term, then div-series should signal an error.) Show how to use div-series together with the result of exercise 3.59 to generate the power series for tangent.
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+(define tangent-series (div-series sine-series cosine-series))
+(test-stream-list
+ tangent-series
+ '(0 1 0 1/3 0 2/15 0 17/315 0 62/2835))
blob - /dev/null
blob + 7764d83a78269482edfedcfb877e53e69e914b36 (mode 644)
--- /dev/null
+++ ex3-64.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+;; (test-stream-list (stream-map exact->inexact (sqrt-stream 2))
+;; '(1 1.5 1.4166 1.4142156 1.41421356))
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+;; (test-stream-list (stream-map exact->inexact pi-stream)
+;; '(4 2.6667 3.4667 2.8952 3.3397))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+;; (test-stream-list (stream-map exact->inexact (euler-transform pi-stream))
+;; '(3.1667 3.1333 3.1452 3.1397 3.1427))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+;; (test-stream-list (stream-map exact->inexact (stream-map stream-car (make-tableau euler-transform pi-stream)))
+;; '(4 3.1667 3.1421 3.1459935 3.1415927140 3.145926539752927))
+
+;; Exercise 3.64. Write a procedure stream-limit that takes as arguments a stream and a number (the tolerance). It should examine the stream until it finds two successive elements that differ in absolute value by less than the tolerance, and return the second of the two elements. Using this, we could compute square roots up to a given tolerance by
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(test-case (sqrt 23.0 0.00000001) 4.79583152)
blob - /dev/null
blob + cf9ab4b7563cc28ab391ad0cdf74ad0ce9ff90c0 (mode 644)
--- /dev/null
+++ ex3-64.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+;; (test-stream-list (stream-map exact->inexact (sqrt-stream 2))
+;; '(1 1.5 1.4166 1.4142156 1.41421356))
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+;; (test-stream-list (stream-map exact->inexact pi-stream)
+;; '(4 2.6667 3.4667 2.8952 3.3397))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+;; (test-stream-list (stream-map exact->inexact (euler-transform pi-stream))
+;; '(3.1667 3.1333 3.1452 3.1397 3.1427))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+;; (test-stream-list (stream-map exact->inexact (stream-map stream-car (make-tableau euler-transform pi-stream)))
+;; '(4 3.1667 3.1421 3.1459935 3.1415927140 3.145926539752927))
+
+;; Exercise 3.63. Louis Reasoner asks why the sqrt-stream procedure was not written in the following more straightforward way, without the local variable guesses:
+
+(define (sqrt-stream x)
+ (cons-stream 1.0
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ (sqrt-stream x))))
+
+;; Alyssa P. Hacker replies that this version of the procedure is considerably less efficient because it performs redundant computation. Explain Alyssa's answer. Would the two versions still differ in efficiency if our implementation of delay used only (lambda () <exp>) without using the optimization provided by memo-proc (section 3.5.1)?
+
+;; by defining guesses, the procedure is able to take advantage of the fact that the previous terms in the stream have been calculated before. When mapping guesses, the delayed objects in the stream which have already been evaluated can simply return their memoized values. Without guesses, each new iteration would require the computation (from scratch) of each previous iteration.
+
+;; without the optimization, the two implementations would be equally inefficient
blob - /dev/null
blob + 5be00566b697916c0392f889562255f1d7ab86a3 (mode 644)
--- /dev/null
+++ ex3-65.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+;; (test-stream-list (stream-map exact->inexact (sqrt-stream 2))
+;; '(1 1.5 1.4166 1.4142156 1.41421356))
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+;; (test-stream-list (stream-map exact->inexact pi-stream)
+;; '(4 2.6667 3.4667 2.8952 3.3397))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+;; (test-stream-list (stream-map exact->inexact (euler-transform pi-stream))
+;; '(3.1667 3.1333 3.1452 3.1397 3.1427))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+;; (test-stream-list (stream-map exact->inexact (stream-map stream-car (make-tableau euler-transform pi-stream)))
+;; '(4 3.1667 3.1421 3.1459935 3.1415927140 3.145926539752927))
+
+;; Exercise 3.64. Write a procedure stream-limit that takes as arguments a stream and a number (the tolerance). It should examine the stream until it finds two successive elements that differ in absolute value by less than the tolerance, and return the second of the two elements. Using this, we could compute square roots up to a given tolerance by
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+;; (test-case (sqrt 23.0 0.00000001) 4.79583152)
+
+;; Exercise 3.65. Use the series
+
+;; ln2 = 1 - 1/2 + 1/3 - 1/4 + ...
+
+;; to compute three sequences of approximations to the natural logarithm of 2, in the same way we did above for . How rapidly do these sequences converge?
+
+(define (ln2-summands n)
+ (cons-stream
+ (/ 1.0 n)
+ (stream-map - (ln2-summands (+ n 1)))))
+(define ln2 (partial-sums (ln2-summands 1)))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(display-streams
+ 10
+ ln2
+ (euler-transform ln2)
+ (stream-map stream-car
+ (make-tableau euler-transform ln2)))
+
blob - /dev/null
blob + 7764d83a78269482edfedcfb877e53e69e914b36 (mode 644)
--- /dev/null
+++ ex3-65.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+;; (test-stream-list (stream-map exact->inexact (sqrt-stream 2))
+;; '(1 1.5 1.4166 1.4142156 1.41421356))
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+;; (test-stream-list (stream-map exact->inexact pi-stream)
+;; '(4 2.6667 3.4667 2.8952 3.3397))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+;; (test-stream-list (stream-map exact->inexact (euler-transform pi-stream))
+;; '(3.1667 3.1333 3.1452 3.1397 3.1427))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+;; (test-stream-list (stream-map exact->inexact (stream-map stream-car (make-tableau euler-transform pi-stream)))
+;; '(4 3.1667 3.1421 3.1459935 3.1415927140 3.145926539752927))
+
+;; Exercise 3.64. Write a procedure stream-limit that takes as arguments a stream and a number (the tolerance). It should examine the stream until it finds two successive elements that differ in absolute value by less than the tolerance, and return the second of the two elements. Using this, we could compute square roots up to a given tolerance by
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(test-case (sqrt 23.0 0.00000001) 4.79583152)
blob - /dev/null
blob + 7367d4fc75b8f2f93f3898373a1f7be3286f7edb (mode 644)
--- /dev/null
+++ ex3-66.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+;; Exercise 3.66. Examine the stream (pairs integers integers). Can you make any general comments about the order in which the pairs are placed into the stream? For example, about how many pairs precede the pair (1,100)? the pair (99,100)? the pair (100,100)? (If you can make precise mathematical statements here, all the better. But feel free to give more qualitative answers if you find yourself getting bogged down.)
+
+;; (define the-pairs (pairs integers integers))
+;; (test-stream-list the-pairs
+;; '((1 1) (1 2) (2 2) (1 3) (2 3) (1 4) (3 3) (1 5) (2 4) (1 6) (3 4) (1 7) (2 5) (1 8) (4 4)))
+
+;; 2(j-1) for the pair (1, j) for j > 1
+;; 2(2(j-2))+1 for the pair (2, j) for j > 1
+;; 2(2(2(j-3)))+3 for the pair (3, j) for j > 1
+;; 2(2(2(2(j-4))))+7 for the pair (4, j) for j > 1
+;; 2(2(2(2(2(j-5)))))+15
+
+;; So, in general, (2^i)(j-i)+[summation of 2^(x-2)] from x = 2 to x = i
+
+;; (1, 100) will appear as term 2(100-1) = 198
+;; (test-case (stream-ref the-pairs 197) '(1 100))
+;; (display-streams 100 the-pairs integers)
+
+(define double-summation (partial-sums double))
+(newline)
+(stream-ref double-summation 97)
+(newline)
+(display "New")
+(newline)
+(stream-ref double-summation 98)
+
blob - /dev/null
blob + e968c8531598162a3d47fbd47620a35feab0c2ed (mode 644)
--- /dev/null
+++ ex3-66.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+;; (test-stream-list (stream-map exact->inexact (sqrt-stream 2))
+;; '(1 1.5 1.4166 1.4142156 1.41421356))
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+;; (test-stream-list (stream-map exact->inexact pi-stream)
+;; '(4 2.6667 3.4667 2.8952 3.3397))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+;; (test-stream-list (stream-map exact->inexact (euler-transform pi-stream))
+;; '(3.1667 3.1333 3.1452 3.1397 3.1427))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+;; (test-stream-list (stream-map exact->inexact (stream-map stream-car (make-tableau euler-transform pi-stream)))
+;; '(4 3.1667 3.1421 3.1459935 3.1415927140 3.145926539752927))
+
+;; Exercise 3.64. Write a procedure stream-limit that takes as arguments a stream and a number (the tolerance). It should examine the stream until it finds two successive elements that differ in absolute value by less than the tolerance, and return the second of the two elements. Using this, we could compute square roots up to a given tolerance by
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+
+(stream-filter
+ (lambda (pair)
+ (prime? (+ (car pair) (cadr pair))))
+ int-pairs)
+
+(pairs S T)
+
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
blob - /dev/null
blob + acbcb770f154b9f81e5e0c53d90e8dc6f33a2182 (mode 644)
--- /dev/null
+++ ex3-67.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+;; Exercise 3.66. Examine the stream (pairs integers integers). Can you make any general comments about the order in which the pairs are placed into the stream? For example, about how many pairs precede the pair (1,100)? the pair (99,100)? the pair (100,100)? (If you can make precise mathematical statements here, all the better. But feel free to give more qualitative answers if you find yourself getting bogged down.)
+
+;; (define the-pairs (pairs integers integers))
+;; (test-stream-list the-pairs
+;; '((1 1) (1 2) (2 2) (1 3) (2 3) (1 4) (3 3) (1 5) (2 4) (1 6) (3 4) (1 7) (2 5) (1 8) (4 4)))
+
+;; 2(j-1) for the pair (1, j) for j > 1
+;; 2(2(j-2))+1 for the pair (2, j) for j > 1
+;; 2(2(2(j-3)))+3 for the pair (3, j) for j > 1
+;; 2(2(2(2(j-4))))+7 for the pair (4, j) for j > 1
+;; 2(2(2(2(2(j-5)))))+15
+
+;; So, in general, (2^i)(j-i)+[summation of 2^(x-2)] from x = 2 to x = i
+
+;; (1, 100) will appear as term 2(100-1) = 198
+;; (test-case (stream-ref the-pairs 197) '(1 100))
+;; (display-streams 100 the-pairs integers)
+
+(define double-summation (partial-sums double))
+;; (newline)
+;; (stream-ref double-summation 97)
+;; (newline)
+;; (stream-ref double-summation 98)
+
+;; Exercise 3.67. Modify the pairs procedure so that (pairs integers integers) will produce the stream of all pairs of integers (i,j) (without the condition i < j). Hint: You will need to mix in an additional stream.
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(test-stream-list
+ (all-pairs integers integers)
+ '((1 1) (2 1) (1 2) (3 1) (2 2) (4 1) (1 3) (5 1) (3 2)))
blob - /dev/null
blob + 7367d4fc75b8f2f93f3898373a1f7be3286f7edb (mode 644)
--- /dev/null
+++ ex3-67.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+;; Exercise 3.66. Examine the stream (pairs integers integers). Can you make any general comments about the order in which the pairs are placed into the stream? For example, about how many pairs precede the pair (1,100)? the pair (99,100)? the pair (100,100)? (If you can make precise mathematical statements here, all the better. But feel free to give more qualitative answers if you find yourself getting bogged down.)
+
+;; (define the-pairs (pairs integers integers))
+;; (test-stream-list the-pairs
+;; '((1 1) (1 2) (2 2) (1 3) (2 3) (1 4) (3 3) (1 5) (2 4) (1 6) (3 4) (1 7) (2 5) (1 8) (4 4)))
+
+;; 2(j-1) for the pair (1, j) for j > 1
+;; 2(2(j-2))+1 for the pair (2, j) for j > 1
+;; 2(2(2(j-3)))+3 for the pair (3, j) for j > 1
+;; 2(2(2(2(j-4))))+7 for the pair (4, j) for j > 1
+;; 2(2(2(2(2(j-5)))))+15
+
+;; So, in general, (2^i)(j-i)+[summation of 2^(x-2)] from x = 2 to x = i
+
+;; (1, 100) will appear as term 2(100-1) = 198
+;; (test-case (stream-ref the-pairs 197) '(1 100))
+;; (display-streams 100 the-pairs integers)
+
+(define double-summation (partial-sums double))
+(newline)
+(stream-ref double-summation 97)
+(newline)
+(display "New")
+(newline)
+(stream-ref double-summation 98)
+
blob - /dev/null
blob + 7866ead49d7359737f506eaf82c29730ddaf6cab (mode 644)
--- /dev/null
+++ ex3-68.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+;; Exercise 3.68. Louis Reasoner thinks that building a stream of pairs from three parts is unnecessarily complicated. Instead of separating the pair (S0,T0) from the rest of the pairs in the first row, he proposes to work with the whole first row, as follows:
+
+(define (pairs s t)
+ (interleave
+ (stream-map (lambda (x) (list (stream-car s) x))
+ t)
+ (pairs (stream-cdr s) (stream-cdr t))))
+
+;; Does this work? Consider what happens if we evaluate (pairs integers integers) using Louis's definition of pairs.
+
+;; This fails because interleave is a regular procedure, so the argument (pairs (stream-cdr s) (stream-cdr t)) will be evaluated. This will result in an infinite loop. We need to delay the expression, but the delay is missing without cons-stream.
+
+ Exercise 3.69. Write a procedure triples that takes three infinite streams, S, T, and U, and produces the stream of triples (Si,Tj,Uk) such that i < j < k. Use triples to generate the stream of all Pythagorean triples of positive integers, i.e., the triples (i,j,k) such that i < j and i2 + j2 = k2.
blob - /dev/null
blob + acbcb770f154b9f81e5e0c53d90e8dc6f33a2182 (mode 644)
--- /dev/null
+++ ex3-68.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+;; Exercise 3.66. Examine the stream (pairs integers integers). Can you make any general comments about the order in which the pairs are placed into the stream? For example, about how many pairs precede the pair (1,100)? the pair (99,100)? the pair (100,100)? (If you can make precise mathematical statements here, all the better. But feel free to give more qualitative answers if you find yourself getting bogged down.)
+
+;; (define the-pairs (pairs integers integers))
+;; (test-stream-list the-pairs
+;; '((1 1) (1 2) (2 2) (1 3) (2 3) (1 4) (3 3) (1 5) (2 4) (1 6) (3 4) (1 7) (2 5) (1 8) (4 4)))
+
+;; 2(j-1) for the pair (1, j) for j > 1
+;; 2(2(j-2))+1 for the pair (2, j) for j > 1
+;; 2(2(2(j-3)))+3 for the pair (3, j) for j > 1
+;; 2(2(2(2(j-4))))+7 for the pair (4, j) for j > 1
+;; 2(2(2(2(2(j-5)))))+15
+
+;; So, in general, (2^i)(j-i)+[summation of 2^(x-2)] from x = 2 to x = i
+
+;; (1, 100) will appear as term 2(100-1) = 198
+;; (test-case (stream-ref the-pairs 197) '(1 100))
+;; (display-streams 100 the-pairs integers)
+
+(define double-summation (partial-sums double))
+;; (newline)
+;; (stream-ref double-summation 97)
+;; (newline)
+;; (stream-ref double-summation 98)
+
+;; Exercise 3.67. Modify the pairs procedure so that (pairs integers integers) will produce the stream of all pairs of integers (i,j) (without the condition i < j). Hint: You will need to mix in an additional stream.
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(test-stream-list
+ (all-pairs integers integers)
+ '((1 1) (2 1) (1 2) (3 1) (2 2) (4 1) (1 3) (5 1) (3 2)))
blob - /dev/null
blob + 54aa1b6f2075549859d33e472eb44bde8efe61a7 (mode 644)
--- /dev/null
+++ ex3-69.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+;; Exercise 3.69. Write a procedure triples that takes three infinite streams, S, T, and U, and produces the stream of triples (Si,Tj,Uk) such that i < j < k. Use triples to generate the stream of all Pythagorean triples of positive integers, i.e., the triples (i,j,k) such that i < j and i2 + j2 = k2.
+
+;; (1 1) (1 1 1)
+;; (1 2) (1 1 2)
+;; (2 2) (1 2 2)
+;; (1 3) (1 1 3)
+;; (2 3) (1 2 3)
+;; (1 4) (1 1 4)
+;; (3 3) (1 3 3)
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(display-streams 20 pythag-triples)
blob - /dev/null
blob + 7866ead49d7359737f506eaf82c29730ddaf6cab (mode 644)
--- /dev/null
+++ ex3-69.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+;; Exercise 3.68. Louis Reasoner thinks that building a stream of pairs from three parts is unnecessarily complicated. Instead of separating the pair (S0,T0) from the rest of the pairs in the first row, he proposes to work with the whole first row, as follows:
+
+(define (pairs s t)
+ (interleave
+ (stream-map (lambda (x) (list (stream-car s) x))
+ t)
+ (pairs (stream-cdr s) (stream-cdr t))))
+
+;; Does this work? Consider what happens if we evaluate (pairs integers integers) using Louis's definition of pairs.
+
+;; This fails because interleave is a regular procedure, so the argument (pairs (stream-cdr s) (stream-cdr t)) will be evaluated. This will result in an infinite loop. We need to delay the expression, but the delay is missing without cons-stream.
+
+ Exercise 3.69. Write a procedure triples that takes three infinite streams, S, T, and U, and produces the stream of triples (Si,Tj,Uk) such that i < j < k. Use triples to generate the stream of all Pythagorean triples of positive integers, i.e., the triples (i,j,k) such that i < j and i2 + j2 = k2.
blob - /dev/null
blob + 285e5f242a5d7fb1367f8b49b8a2cddd02352739 (mode 644)
--- /dev/null
+++ ex3-70.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+;; Exercise 3.70. It would be nice to be able to generate streams in which the pairs appear in some useful order, rather than in the order that results from an ad hoc interleaving process. We can use a technique similar to the merge procedure of exercise 3.56, if we define a way to say that one pair of integers is ``less than'' another. One way to do this is to define a ``weighting function'' W(i,j) and stipulate that (i1,j1) is less than (i2,j2) if W(i1,j1) < W(i2,j2). Write a procedure merge-weighted that is like merge, except that merge-weighted takes an additional argument weight, which is a procedure that computes the weight of a pair, and is used to determine the order in which elements should appear in the resulting merged stream.69 Using this, generalize pairs to a procedure weighted-pairs that takes two streams, together with a procedure that computes a weighting function, and generates the stream of pairs, ordered according to weight. Use your procedure to generate
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+;; a. the stream of all pairs of positive integers (i,j) with i < j ordered according to the sum i + j
+
+;; (1 1)
+;; (1 2) (1 3) (1 4) (1 5) (1 6)
+;; (2 2)
+;; (2 3) (2 4) (2 5) (2 6) (2 7)
+;; (3 3) ...
+
+(define i<j (weighted-pairs integers integers (lambda (pair) (apply + pair))))
+(test-stream-list i<j '((1 1) (1 2) (1 3) (2 2) (1 4) (2 3) (1 5) (2 4) (3 3) (1 6) (2 5) (3 4)))
+
+;; b. the stream of all pairs of positive integers (i,j) with i < j, where neither i nor j is divisible by 2, 3, or 5, and the pairs are ordered according to the sum 2 i + 3 j + 5 i j.
+
+(define no235 (stream-filter (lambda (x)
+ (not (or (divisible? x 2)
+ (divisible? x 3)
+ (divisible? x 5))))
+ integers))
+
+(define no235-pairs
+ (weighted-pairs
+ no235
+ no235
+ (lambda (pair)
+ (let ((i (car pair))
+ (j (cadr pair)))
+ (+ (* 2 i)
+ (* 3 j)
+ (* 5 i j))))))
+
+(display-streams 20 no235 no235-pairs)
blob - /dev/null
blob + 473f0451e850a90c062b8cbc727020bb7b6fcf1d (mode 644)
--- /dev/null
+++ ex3-70.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+;; Exercise 3.70. It would be nice to be able to generate streams in which the pairs appear in some useful order, rather than in the order that results from an ad hoc interleaving process. We can use a technique similar to the merge procedure of exercise 3.56, if we define a way to say that one pair of integers is ``less than'' another. One way to do this is to define a ``weighting function'' W(i,j) and stipulate that (i1,j1) is less than (i2,j2) if W(i1,j1) < W(i2,j2). Write a procedure merge-weighted that is like merge, except that merge-weighted takes an additional argument weight, which is a procedure that computes the weight of a pair, and is used to determine the order in which elements should appear in the resulting merged stream.69 Using this, generalize pairs to a procedure weighted-pairs that takes two streams, together with a procedure that computes a weighting function, and generates the stream of pairs, ordered according to weight. Use your procedure to generate
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (let ((s1cdr))
+
+ (weight s)
+
+;; a. the stream of all pairs of positive integers (i,j) with i < j ordered according to the sum i + j
+
+(merge-weighted (pairs integers integers)
+ (lambda (pair) (apply + pair)))
+
+b. the stream of all pairs of positive integers (i,j) with i < j, where neither i nor j is divisible by 2, 3, or 5, and the pairs are ordered according to the sum 2 i + 3 j + 5 i j.
blob - /dev/null
blob + c746edb2b5221160ac716969ee8305c7bca8b6e8 (mode 644)
--- /dev/null
+++ ex3-71.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+;; Exercise 3.71. Numbers that can be expressed as the sum of two cubes in more than one way are sometimes called Ramanujan numbers, in honor of the mathematician Srinivasa Ramanujan.70 Ordered streams of pairs provide an elegant solution to the problem of computing these numbers. To find a number that can be written as the sum of two cubes in two different ways, we need only generate the stream of pairs of integers (i,j) weighted according to the sum i3 + j3 (see exercise 3.70), then search the stream for two consecutive pairs with the same weight. Write a procedure to generate the Ramanujan numbers. The first such number is 1,729. What are the next five?
+
+(define (i3+j3 pair)
+ (let ((i (car pair))
+ (j (cadr pair)))
+ (+ (* i i i)
+ (* j j j))))
+
+
+(define i3+j3-pairs (weighted-pairs integers integers i3+j3))
+
+(define (two-same-weight s weight)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (= (weight scar) (weight scadr))
+ (cons-stream (list scar scadr (weight scar))
+ (two-same-weight scdr weight))
+ (two-same-weight scdr weight))))
+
+(define ramanujan (two-same-weight i3+j3-pairs i3+j3))
+(test-stream-list ramanujan '(1729 4104 13832 20683 32832 39312))
+
blob - /dev/null
blob + 285e5f242a5d7fb1367f8b49b8a2cddd02352739 (mode 644)
--- /dev/null
+++ ex3-71.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+;; Exercise 3.70. It would be nice to be able to generate streams in which the pairs appear in some useful order, rather than in the order that results from an ad hoc interleaving process. We can use a technique similar to the merge procedure of exercise 3.56, if we define a way to say that one pair of integers is ``less than'' another. One way to do this is to define a ``weighting function'' W(i,j) and stipulate that (i1,j1) is less than (i2,j2) if W(i1,j1) < W(i2,j2). Write a procedure merge-weighted that is like merge, except that merge-weighted takes an additional argument weight, which is a procedure that computes the weight of a pair, and is used to determine the order in which elements should appear in the resulting merged stream.69 Using this, generalize pairs to a procedure weighted-pairs that takes two streams, together with a procedure that computes a weighting function, and generates the stream of pairs, ordered according to weight. Use your procedure to generate
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+;; a. the stream of all pairs of positive integers (i,j) with i < j ordered according to the sum i + j
+
+;; (1 1)
+;; (1 2) (1 3) (1 4) (1 5) (1 6)
+;; (2 2)
+;; (2 3) (2 4) (2 5) (2 6) (2 7)
+;; (3 3) ...
+
+(define i<j (weighted-pairs integers integers (lambda (pair) (apply + pair))))
+(test-stream-list i<j '((1 1) (1 2) (1 3) (2 2) (1 4) (2 3) (1 5) (2 4) (3 3) (1 6) (2 5) (3 4)))
+
+;; b. the stream of all pairs of positive integers (i,j) with i < j, where neither i nor j is divisible by 2, 3, or 5, and the pairs are ordered according to the sum 2 i + 3 j + 5 i j.
+
+(define no235 (stream-filter (lambda (x)
+ (not (or (divisible? x 2)
+ (divisible? x 3)
+ (divisible? x 5))))
+ integers))
+
+(define no235-pairs
+ (weighted-pairs
+ no235
+ no235
+ (lambda (pair)
+ (let ((i (car pair))
+ (j (cadr pair)))
+ (+ (* 2 i)
+ (* 3 j)
+ (* 5 i j))))))
+
+(display-streams 20 no235 no235-pairs)
blob - /dev/null
blob + b7445ab8e4f599227b54e9186342abb8fe65b499 (mode 644)
--- /dev/null
+++ ex3-72.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+;; Exercise 3.71. Numbers that can be expressed as the sum of two cubes in more than one way are sometimes called Ramanujan numbers, in honor of the mathematician Srinivasa Ramanujan.70 Ordered streams of pairs provide an elegant solution to the problem of computing these numbers. To find a number that can be written as the sum of two cubes in two different ways, we need only generate the stream of pairs of integers (i,j) weighted according to the sum i3 + j3 (see exercise 3.70), then search the stream for two consecutive pairs with the same weight. Write a procedure to generate the Ramanujan numbers. The first such number is 1,729. What are the next five?
+
+(define (i3+j3 pair)
+ (let ((i (car pair))
+ (j (cadr pair)))
+ (+ (* i i i)
+ (* j j j))))
+
+
+(define i3+j3-pairs (weighted-pairs integers integers i3+j3))
+
+(define (two-same-weight s weight)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (= (weight scar) (weight scadr))
+ (cons-stream (list scar scadr (weight scar))
+ (two-same-weight scdr weight))
+ (two-same-weight scdr weight))))
+
+;; (define ramanujan (two-same-weight i3+j3-pairs i3+j3))
+;; (test-stream-list ramanujan '(1729 4104 13832 20683 32832 39312))
+
+;; Exercise 3.72. In a similar way to exercise 3.71 generate a stream of all numbers that can be written as the sum of two squares in three different ways (showing how they can be so written).
+
+(define (i2+j2 pair)
+ (let ((i (car pair))
+ (j (cadr pair)))
+ (+ (* i i)
+ (* j j))))
+
+(define i2+j2-pairs (weighted-pairs integers integers i2+j2))
+(define (three-same-weight s weight)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr))
+ (scddr (stream-cdr scdr))
+ (scaddr (stream-car scddr)))
+ (if (= (weight scar) (weight scadr) (weight scaddr))
+ (cons-stream (list scar scadr scaddr (weight scar))
+ (three-same-weight scdr weight))
+ (three-same-weight scdr weight))))
+(define three-ways (three-same-weight i2+j2-pairs i2+j2))
+(display-streams 10 three-ways)
+
blob - /dev/null
blob + c746edb2b5221160ac716969ee8305c7bca8b6e8 (mode 644)
--- /dev/null
+++ ex3-72.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+(define no-sevens
+ (stream-filter (lambda (x) (not (divisible? x 7)))
+ integers))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+;; (define primes (sieve (integers-starting-from 2)))
+;; (test-case (stream-ref primes 25) 101)
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+;; (test-case (stream-ref integers 15) 16)
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+(define double (cons-stream 1 (scale-stream double 2)))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+;; Exercise 3.71. Numbers that can be expressed as the sum of two cubes in more than one way are sometimes called Ramanujan numbers, in honor of the mathematician Srinivasa Ramanujan.70 Ordered streams of pairs provide an elegant solution to the problem of computing these numbers. To find a number that can be written as the sum of two cubes in two different ways, we need only generate the stream of pairs of integers (i,j) weighted according to the sum i3 + j3 (see exercise 3.70), then search the stream for two consecutive pairs with the same weight. Write a procedure to generate the Ramanujan numbers. The first such number is 1,729. What are the next five?
+
+(define (i3+j3 pair)
+ (let ((i (car pair))
+ (j (cadr pair)))
+ (+ (* i i i)
+ (* j j j))))
+
+
+(define i3+j3-pairs (weighted-pairs integers integers i3+j3))
+
+(define (two-same-weight s weight)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (= (weight scar) (weight scadr))
+ (cons-stream (list scar scadr (weight scar))
+ (two-same-weight scdr weight))
+ (two-same-weight scdr weight))))
+
+(define ramanujan (two-same-weight i3+j3-pairs i3+j3))
+(test-stream-list ramanujan '(1729 4104 13832 20683 32832 39312))
+
blob - /dev/null
blob + e07c86bd933851a971dec2caa203ec5dfddd6f9f (mode 644)
--- /dev/null
+++ ex3-73.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+;; Exercise 3.73
+
+;; We can model electrical circuits using streams to represent the values of currents or voltages at a sequence of times. For instance, suppose we have an RC circuit consisting of a resistor of resistance R and a capacitor of capacitance C in series. The voltage response v of the circuit to an injected current i is determined by the formula in figure 3.33, whose structure is shown by the accompanying signal-flow diagram.
+
+;; Write a procedure RC that models this circuit. RC should take as inputs the values of R, C, and dt and should return a procedure that takes as inputs a stream representing the current i and an initial value for the capacitor voltage v0 and produces as output the stream of voltages v. For example, you should be able to use RC to model an RC circuit with R = 5 ohms, C = 1 farad, and a 0.5-second time step by evaluating (define RC1 (RC 5 1 0.5)). This defines RC1 as a procedure that takes a stream representing the time sequence of currents and an initial capacitor voltage and produces the output stream of voltages.
+
+(define (RC R C dt)
+ (lambda (i v0)
+ (add-streams (integral (scale-stream i (/ 1 C)) v0 dt)
+ (scale-stream i R))))
+(define RC1 (RC 5 1 0.5))
+;; (test-stream-list (RC1 integers 0.2) '(5.2 10.7 16.7 32.2 30.2))
+;; not even sure if this test makes sense, I just copied it from Barry Allison's site
blob - /dev/null
blob + f3c3fe21adb616a44d89660c98496b6d35737f55 (mode 644)
--- /dev/null
+++ ex3-73.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
blob - /dev/null
blob + e464be065adb0f667059bba5e7c1675c8dac15b1 (mode 644)
--- /dev/null
+++ ex3-74.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+;; Exercise 3.74. Alyssa P. Hacker is designing a system to process signals coming from physical sensors. One important feature she wishes to produce is a signal that describes the zero crossings of the input signal. That is, the resulting signal should be + 1 whenever the input signal changes from negative to positive, - 1 whenever the input signal changes from positive to negative, and 0 otherwise. (Assume that the sign of a 0 input is positive.) For example, a typical input signal with its associated zero-crossing signal would be
+
+;;1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4
+;;0 0 0 0 0 -1 0 0 0 0 1 0
+
+;; In Alyssa's system, the signal from the sensor is represented as a stream sense-data and the stream zero-crossings is the corresponding stream of zero crossings. Alyssa first writes a procedure sign-change-detector that takes two values as arguments and compares the signs of the values to produce an appropriate 0, 1, or - 1. She then constructs her zero-crossing stream as follows:
+
+(define (sign-change-detector current-value last-value)
+ (cond ((and (< current-value 0) (>= last-value 0)) -1)
+ ((and (>= current-value 0) (< last-value 0)) 1)
+ (else 0)))
+
+(define (make-zero-crossings input-stream last-value)
+ (cons-stream
+ (sign-change-detector (stream-car input-stream) last-value)
+ (make-zero-crossings (stream-cdr input-stream)
+ (stream-car input-stream))))
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+;; (define zero-crossings (make-zero-crossings sense-data 0))
+
+;; Alyssa's boss, Eva Lu Ator, walks by and suggests that this program is approximately equivalent to the following one, which uses the generalized version of stream-map from exercise 3.50:
+
+(define zero-crossings
+ (stream-map sign-change-detector
+ sense-data
+ (cons-stream 0 sense-data)))
+
+(define sense-data (list->stream '(1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4)))
+(newline)
+(test-stream-list zero-crossings '(0 0 0 0 0 -1 0 0 0 0 1 0))
blob - /dev/null
blob + e07c86bd933851a971dec2caa203ec5dfddd6f9f (mode 644)
--- /dev/null
+++ ex3-74.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+;; Exercise 3.73
+
+;; We can model electrical circuits using streams to represent the values of currents or voltages at a sequence of times. For instance, suppose we have an RC circuit consisting of a resistor of resistance R and a capacitor of capacitance C in series. The voltage response v of the circuit to an injected current i is determined by the formula in figure 3.33, whose structure is shown by the accompanying signal-flow diagram.
+
+;; Write a procedure RC that models this circuit. RC should take as inputs the values of R, C, and dt and should return a procedure that takes as inputs a stream representing the current i and an initial value for the capacitor voltage v0 and produces as output the stream of voltages v. For example, you should be able to use RC to model an RC circuit with R = 5 ohms, C = 1 farad, and a 0.5-second time step by evaluating (define RC1 (RC 5 1 0.5)). This defines RC1 as a procedure that takes a stream representing the time sequence of currents and an initial capacitor voltage and produces the output stream of voltages.
+
+(define (RC R C dt)
+ (lambda (i v0)
+ (add-streams (integral (scale-stream i (/ 1 C)) v0 dt)
+ (scale-stream i R))))
+(define RC1 (RC 5 1 0.5))
+;; (test-stream-list (RC1 integers 0.2) '(5.2 10.7 16.7 32.2 30.2))
+;; not even sure if this test makes sense, I just copied it from Barry Allison's site
blob - /dev/null
blob + f018d9bcd2a16d444917ebf42d6ff13dcd995625 (mode 644)
--- /dev/null
+++ ex3-75.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+;; Exercise 3.74. Alyssa P. Hacker is designing a system to process signals coming from physical sensors. One important feature she wishes to produce is a signal that describes the zero crossings of the input signal. That is, the resulting signal should be + 1 whenever the input signal changes from negative to positive, - 1 whenever the input signal changes from positive to negative, and 0 otherwise. (Assume that the sign of a 0 input is positive.) For example, a typical input signal with its associated zero-crossing signal would be
+
+;;1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4
+;;0 0 0 0 0 -1 0 0 0 0 1 0
+
+;; In Alyssa's system, the signal from the sensor is represented as a stream sense-data and the stream zero-crossings is the corresponding stream of zero crossings. Alyssa first writes a procedure sign-change-detector that takes two values as arguments and compares the signs of the values to produce an appropriate 0, 1, or - 1. She then constructs her zero-crossing stream as follows:
+
+(define (sign-change-detector current-value last-value)
+ (cond ((and (< current-value 0) (>= last-value 0)) -1)
+ ((and (>= current-value 0) (< last-value 0)) 1)
+ (else 0)))
+
+(define (make-zero-crossings input-stream last-value)
+ (cons-stream
+ (sign-change-detector (stream-car input-stream) last-value)
+ (make-zero-crossings (stream-cdr input-stream)
+ (stream-car input-stream))))
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+;; (define zero-crossings (make-zero-crossings sense-data 0))
+
+;; Alyssa's boss, Eva Lu Ator, walks by and suggests that this program is approximately equivalent to the following one, which uses the generalized version of stream-map from exercise 3.50:
+
+(define zero-crossings
+ (stream-map sign-change-detector
+ sense-data
+ (cons-stream 0 sense-data)))
+
+(define sense-data (list->stream '(1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4)))
+;; (newline)
+;; (test-stream-list zero-crossings '(0 0 0 0 0 -1 0 0 0 0 1 0))
+
+;; Exercise 3.75. Unfortunately, Alyssa's zero-crossing detector in exercise 3.74 proves to be insufficient, because the noisy signal from the sensor leads to spurious zero crossings. Lem E. Tweakit, a hardware specialist, suggests that Alyssa smooth the signal to filter out the noise before extracting the zero crossings. Alyssa takes his advice and decides to extract the zero crossings from the signal constructed by averaging each value of the sense data with the previous value. She explains the problem to her assistant, Louis Reasoner, who attempts to implement the idea, altering Alyssa's program as follows:
+
+;; (define (make-zero-crossings input-stream last-value)
+;; (let ((avpt (/ (+ (stream-car input-stream) last-value) 2)))
+;; (cons-stream (sign-change-detector avpt last-value)
+;; (make-zero-crossings (stream-cdr input-stream)
+;; avpt))))
+
+;; The problem is that (make-zero-crossings (stream-cdr input-stream) avpt) passes avpt as the last value but this is not really the last value. This has already been averaged and so is not part of the original data.
+
+(define (make-zero-crossings input-stream last-value last-avg)
+ (let ((avpt (/ (+ (stream-car input-stream) last-value) 2)))
+ (cons-stream (sign-change-detector avpt last-avg)
+ (make-zero-crossings (stream-cdr input-stream)
+ (stream-car input-stream)
+ avpt))))
+
+;; This does not correctly implement Alyssa's plan. Find the bug that Louis has installed and fix it without changing the structure of the program. (Hint: You will need to increase the number of arguments to make-zero-crossings.)
blob - /dev/null
blob + e464be065adb0f667059bba5e7c1675c8dac15b1 (mode 644)
--- /dev/null
+++ ex3-75.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+;; Exercise 3.74. Alyssa P. Hacker is designing a system to process signals coming from physical sensors. One important feature she wishes to produce is a signal that describes the zero crossings of the input signal. That is, the resulting signal should be + 1 whenever the input signal changes from negative to positive, - 1 whenever the input signal changes from positive to negative, and 0 otherwise. (Assume that the sign of a 0 input is positive.) For example, a typical input signal with its associated zero-crossing signal would be
+
+;;1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4
+;;0 0 0 0 0 -1 0 0 0 0 1 0
+
+;; In Alyssa's system, the signal from the sensor is represented as a stream sense-data and the stream zero-crossings is the corresponding stream of zero crossings. Alyssa first writes a procedure sign-change-detector that takes two values as arguments and compares the signs of the values to produce an appropriate 0, 1, or - 1. She then constructs her zero-crossing stream as follows:
+
+(define (sign-change-detector current-value last-value)
+ (cond ((and (< current-value 0) (>= last-value 0)) -1)
+ ((and (>= current-value 0) (< last-value 0)) 1)
+ (else 0)))
+
+(define (make-zero-crossings input-stream last-value)
+ (cons-stream
+ (sign-change-detector (stream-car input-stream) last-value)
+ (make-zero-crossings (stream-cdr input-stream)
+ (stream-car input-stream))))
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+;; (define zero-crossings (make-zero-crossings sense-data 0))
+
+;; Alyssa's boss, Eva Lu Ator, walks by and suggests that this program is approximately equivalent to the following one, which uses the generalized version of stream-map from exercise 3.50:
+
+(define zero-crossings
+ (stream-map sign-change-detector
+ sense-data
+ (cons-stream 0 sense-data)))
+
+(define sense-data (list->stream '(1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4)))
+(newline)
+(test-stream-list zero-crossings '(0 0 0 0 0 -1 0 0 0 0 1 0))
blob - /dev/null
blob + 26fdaf4cc8996e8dd04a47b1c99beeb0309a5d14 (mode 644)
--- /dev/null
+++ ex3-76.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+;; Exercise 3.74. Alyssa P. Hacker is designing a system to process signals coming from physical sensors. One important feature she wishes to produce is a signal that describes the zero crossings of the input signal. That is, the resulting signal should be + 1 whenever the input signal changes from negative to positive, - 1 whenever the input signal changes from positive to negative, and 0 otherwise. (Assume that the sign of a 0 input is positive.) For example, a typical input signal with its associated zero-crossing signal would be
+
+;;1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4
+;;0 0 0 0 0 -1 0 0 0 0 1 0
+
+;; In Alyssa's system, the signal from the sensor is represented as a stream sense-data and the stream zero-crossings is the corresponding stream of zero crossings. Alyssa first writes a procedure sign-change-detector that takes two values as arguments and compares the signs of the values to produce an appropriate 0, 1, or - 1. She then constructs her zero-crossing stream as follows:
+
+(define (sign-change-detector current-value last-value)
+ (cond ((and (< current-value 0) (>= last-value 0)) -1)
+ ((and (>= current-value 0) (< last-value 0)) 1)
+ (else 0)))
+
+(define (make-zero-crossings input-stream last-value)
+ (cons-stream
+ (sign-change-detector (stream-car input-stream) last-value)
+ (make-zero-crossings (stream-cdr input-stream)
+ (stream-car input-stream))))
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+;; (define zero-crossings (make-zero-crossings sense-data 0))
+
+;; Alyssa's boss, Eva Lu Ator, walks by and suggests that this program is approximately equivalent to the following one, which uses the generalized version of stream-map from exercise 3.50:
+
+(define zero-crossings
+ (stream-map sign-change-detector
+ sense-data
+ (cons-stream 0 sense-data)))
+
+(define sense-data (list->stream '(1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4)))
+;; (newline)
+;; (test-stream-list zero-crossings '(0 0 0 0 0 -1 0 0 0 0 1 0))
+
+;; Exercise 3.75. Unfortunately, Alyssa's zero-crossing detector in exercise 3.74 proves to be insufficient, because the noisy signal from the sensor leads to spurious zero crossings. Lem E. Tweakit, a hardware specialist, suggests that Alyssa smooth the signal to filter out the noise before extracting the zero crossings. Alyssa takes his advice and decides to extract the zero crossings from the signal constructed by averaging each value of the sense data with the previous value. She explains the problem to her assistant, Louis Reasoner, who attempts to implement the idea, altering Alyssa's program as follows:
+
+;; (define (make-zero-crossings input-stream last-value)
+;; (let ((avpt (/ (+ (stream-car input-stream) last-value) 2)))
+;; (cons-stream (sign-change-detector avpt last-value)
+;; (make-zero-crossings (stream-cdr input-stream)
+;; avpt))))
+
+;; The problem is that (make-zero-crossings (stream-cdr input-stream) avpt) passes avpt as the last value but this is not really the last value. This has already been averaged and so is not part of the original data.
+
+(define (make-zero-crossings-louis input-stream last-value last-avg)
+ (let ((avpt (/ (+ (stream-car input-stream) last-value) 2)))
+ (cons-stream (sign-change-detector avpt last-avg)
+ (make-zero-crossings-louis (stream-cdr input-stream)
+ (stream-car input-stream)
+ avpt))))
+
+;; This does not correctly implement Alyssa's plan. Find the bug that Louis has installed and fix it without changing the structure of the program. (Hint: You will need to increase the number of arguments to make-zero-crossings.)
+
+;; Exercise 3.76. Eva Lu Ator has a criticism of Louis's approach in exercise 3.75. The program he wrote is not modular, because it intermixes the operation of smoothing with the zero-crossing extraction. For example, the extractor should not have to be changed if Alyssa finds a better way to condition her input signal. Help Louis by writing a procedure smooth that takes a stream as input and produces a stream in which each element is the average of two successive input stream elements. Then use smooth as a component to implement the zero-crossing detector in a more modular style.
+
+(define (smooth input-stream)
+ (let ((scdr (stream-cdr input-stream)))
+ (cons-stream (/ (+ (stream-car input-stream)
+ (stream-car scdr)) 2)
+ (smooth scdr))))
+
+(newline)
+(display-streams 10
+ (make-zero-crossings (smooth sense-data) 0)
+ (make-zero-crossings-louis sense-data 0 0))
blob - /dev/null
blob + 48940e00dfe4f9c1a9e92bcf3275e63e6dfa1948 (mode 644)
--- /dev/null
+++ ex3-76.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+;; Exercise 3.74. Alyssa P. Hacker is designing a system to process signals coming from physical sensors. One important feature she wishes to produce is a signal that describes the zero crossings of the input signal. That is, the resulting signal should be + 1 whenever the input signal changes from negative to positive, - 1 whenever the input signal changes from positive to negative, and 0 otherwise. (Assume that the sign of a 0 input is positive.) For example, a typical input signal with its associated zero-crossing signal would be
+
+;;1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4
+;;0 0 0 0 0 -1 0 0 0 0 1 0
+
+;; In Alyssa's system, the signal from the sensor is represented as a stream sense-data and the stream zero-crossings is the corresponding stream of zero crossings. Alyssa first writes a procedure sign-change-detector that takes two values as arguments and compares the signs of the values to produce an appropriate 0, 1, or - 1. She then constructs her zero-crossing stream as follows:
+
+(define (sign-change-detector current-value last-value)
+ (cond ((and (< current-value 0) (>= last-value 0)) -1)
+ ((and (>= current-value 0) (< last-value 0)) 1)
+ (else 0)))
+
+(define (make-zero-crossings input-stream last-value)
+ (cons-stream
+ (sign-change-detector (stream-car input-stream) last-value)
+ (make-zero-crossings (stream-cdr input-stream)
+ (stream-car input-stream))))
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+;; (define zero-crossings (make-zero-crossings sense-data 0))
+
+;; Alyssa's boss, Eva Lu Ator, walks by and suggests that this program is approximately equivalent to the following one, which uses the generalized version of stream-map from exercise 3.50:
+
+(define zero-crossings
+ (stream-map sign-change-detector
+ sense-data
+ (cons-stream 0 sense-data)))
+
+(define sense-data (list->stream '(1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4)))
+;; (newline)
+;; (test-stream-list zero-crossings '(0 0 0 0 0 -1 0 0 0 0 1 0))
+
+;; Exercise 3.75. Unfortunately, Alyssa's zero-crossing detector in exercise 3.74 proves to be insufficient, because the noisy signal from the sensor leads to spurious zero crossings. Lem E. Tweakit, a hardware specialist, suggests that Alyssa smooth the signal to filter out the noise before extracting the zero crossings. Alyssa takes his advice and decides to extract the zero crossings from the signal constructed by averaging each value of the sense data with the previous value. She explains the problem to her assistant, Louis Reasoner, who attempts to implement the idea, altering Alyssa's program as follows:
+
+;; (define (make-zero-crossings input-stream last-value)
+;; (let ((avpt (/ (+ (stream-car input-stream) last-value) 2)))
+;; (cons-stream (sign-change-detector avpt last-value)
+;; (make-zero-crossings (stream-cdr input-stream)
+;; avpt))))
+
+;; The problem is that (make-zero-crossings (stream-cdr input-stream) avpt) passes avpt as the last value but this is not really the last value. This has already been averaged and so is not part of the original data.
+
+(define (make-zero-crossings input-stream last-value last-avg)
+ (let ((avpt (/ (+ (stream-car input-stream) last-value) 2)))
+ (cons-stream (sign-change-detector avpt last-avg)
+ (make-zero-crossings (stream-cdr input-stream)
+ (stream-car input-stream)
+ avpt))))
+
+;; This does not correctly implement Alyssa's plan. Find the bug that Louis has installed and fix it without changing the structure of the program. (Hint: You will need to increase the number of arguments to make-zero-crossings.)
+
+ Exercise 3.76. Eva Lu Ator has a criticism of Louis's approach in exercise 3.75. The program he wrote is not modular, because it intermixes the operation of smoothing with the zero-crossing extraction. For example, the extractor should not have to be changed if Alyssa finds a better way to condition her input signal. Help Louis by writing a procedure smooth that takes a stream as input and produces a stream in which each element is the average of two successive input stream elements. Then use smooth as a component to implement the zero-crossing detector in a more modular style.
blob - /dev/null
blob + 1df5f6a758b7d17f4df77e05eaac8da4ecb62da1 (mode 644)
--- /dev/null
+++ ex3-77.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+;; (define (integral delayed-integrand initial-value dt)
+;; (define int
+;; (cons-stream initial-value
+;; (let ((integrand (myforce delayed-integrand)))
+;; (add-streams (scale-stream integrand dt)
+;; int))))
+;; int)
+
+;; Exercise 3.77. The integral procedure used above was analogous to the ``implicit'' definition of the infinite stream of integers in section 3.5.2. Alternatively, we can give a definition of integral that is more like integers-starting-from (also in section 3.5.2):
+
+;; (define (integral integrand initial-value dt)
+;; (cons-stream initial-value
+;; (if (stream-null? integrand)
+;; the-empty-stream
+;; (integral (stream-cdr integrand)
+;; (+ (* dt (stream-car integrand))
+;; initial-value)
+;; dt))))
+
+;; When used in systems with loops, this procedure has the same problem as does our original version of integral. Modify the procedure so that it expects the integrand as a delayed argument and hence can be used in the solve procedure shown above.
+
+(define (integral delayed-integrand initial-value dt)
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (if (stream-null? integrand)
+ the-empty-stream
+ (integral (mydelay (stream-cdr integrand))
+ (+ (* dt (stream-car integrand))
+ initial-value)
+ dt)))))
+
+(test-case (stream-ref (solve (lambda (y) y) 1 0.001) 1000)
+ 2.718)
blob - /dev/null
blob + bf680e397c5dfefd78fe92dafcd1a0fac8087fac (mode 644)
--- /dev/null
+++ ex3-77.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+
+(define int
+ (cons-stream initial-value
+ (add-streas (scale-stream integrand dt)
+ int)))
blob - /dev/null
blob + 2e65249a9eb8f70acb21ec2d5497a8793bb479e8 (mode 644)
--- /dev/null
+++ ex3-78.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+(define (integral delayed-integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (add-streams (scale-stream integrand dt)
+ int))))
+ int)
+
+;; Exercise 3.78.
+
+;; Figure 3.35: Signal-flow diagram for the solution to a second-order linear differential equation.
+
+;; Consider the problem of designing a signal-processing system to study the homogeneous second-order linear differential equation
+
+;; The output stream, modeling y, is generated by a network that contains a loop. This is because the value of d2y/dt2 depends upon the values of y and dy/dt and both of these are determined by integrating d2y/dt2. The diagram we would like to encode is shown in figure 3.35. Write a procedure solve-2nd that takes as arguments the constants a, b, and dt and the initial values y0 and dy0 for y and dy/dt and generates the stream of successive values of y.
+
+(define (solve-2nd a b y0 dy0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (integral (mydelay ddy) dy0 dt))
+ (define ddy (add-streams (scale-stream dy a)
+ (scale-stream y b)))
+ y)
blob - /dev/null
blob + 1df5f6a758b7d17f4df77e05eaac8da4ecb62da1 (mode 644)
--- /dev/null
+++ ex3-78.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+;; (define (integral delayed-integrand initial-value dt)
+;; (define int
+;; (cons-stream initial-value
+;; (let ((integrand (myforce delayed-integrand)))
+;; (add-streams (scale-stream integrand dt)
+;; int))))
+;; int)
+
+;; Exercise 3.77. The integral procedure used above was analogous to the ``implicit'' definition of the infinite stream of integers in section 3.5.2. Alternatively, we can give a definition of integral that is more like integers-starting-from (also in section 3.5.2):
+
+;; (define (integral integrand initial-value dt)
+;; (cons-stream initial-value
+;; (if (stream-null? integrand)
+;; the-empty-stream
+;; (integral (stream-cdr integrand)
+;; (+ (* dt (stream-car integrand))
+;; initial-value)
+;; dt))))
+
+;; When used in systems with loops, this procedure has the same problem as does our original version of integral. Modify the procedure so that it expects the integrand as a delayed argument and hence can be used in the solve procedure shown above.
+
+(define (integral delayed-integrand initial-value dt)
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (if (stream-null? integrand)
+ the-empty-stream
+ (integral (mydelay (stream-cdr integrand))
+ (+ (* dt (stream-car integrand))
+ initial-value)
+ dt)))))
+
+(test-case (stream-ref (solve (lambda (y) y) 1 0.001) 1000)
+ 2.718)
blob - /dev/null
blob + d2ae4f3e4799583534b69490aeae9e93e1c9890c (mode 644)
--- /dev/null
+++ ex3-79.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+(define (integral delayed-integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (add-streams (scale-stream integrand dt)
+ int))))
+ int)
+
+(define (solve-2nd a b y0 dy0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (integral (mydelay ddy) dy0 dt))
+ (define ddy (add-streams (scale-stream dy a)
+ (scale-stream y b)))
+ y)
+
+;; Exercise 3.79. Generalize the solve-2nd procedure of exercise 3.78 so that it can be used to solve general second-order differential equations d2 y/dt2 = f(dy/dt, y).
+
+(define (solve-2nd f y0 dy0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (integral (mydelay ddy) dy0 dt))
+ (define ddy (stream-map f dy y))
+ y)
blob - /dev/null
blob + 2e65249a9eb8f70acb21ec2d5497a8793bb479e8 (mode 644)
--- /dev/null
+++ ex3-79.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+(define (integral delayed-integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (add-streams (scale-stream integrand dt)
+ int))))
+ int)
+
+;; Exercise 3.78.
+
+;; Figure 3.35: Signal-flow diagram for the solution to a second-order linear differential equation.
+
+;; Consider the problem of designing a signal-processing system to study the homogeneous second-order linear differential equation
+
+;; The output stream, modeling y, is generated by a network that contains a loop. This is because the value of d2y/dt2 depends upon the values of y and dy/dt and both of these are determined by integrating d2y/dt2. The diagram we would like to encode is shown in figure 3.35. Write a procedure solve-2nd that takes as arguments the constants a, b, and dt and the initial values y0 and dy0 for y and dy/dt and generates the stream of successive values of y.
+
+(define (solve-2nd a b y0 dy0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (integral (mydelay ddy) dy0 dt))
+ (define ddy (add-streams (scale-stream dy a)
+ (scale-stream y b)))
+ y)
blob - /dev/null
blob + 099dbdece4e7c08525051cdadc918b82c49dfab6 (mode 644)
--- /dev/null
+++ ex3-80.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+(define (integral delayed-integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (add-streams (scale-stream integrand dt)
+ int))))
+ int)
+
+;; (define (solve-2nd a b y0 dy0 dt)
+;; (define y (integral (mydelay dy) y0 dt))
+;; (define dy (integral (mydelay ddy) dy0 dt))
+;; (define ddy (add-streams (scale-stream dy a)
+;; (scale-stream y b)))
+;; y)
+
+;; (define (solve-2nd f y0 dy0 dt)
+;; (define y (integral (mydelay dy) y0 dt))
+;; (define dy (integral (mydelay ddy) dy0 dt))
+;; (define ddy (stream-map f dy y))
+;; y)
+
+;; Write a procedure RLC that takes as arguments the parameters R, L, and C of the circuit and the time increment dt. In a manner similar to that of the RC procedure of exercise 3.73, RLC should produce a procedure that takes the initial values of the state variables, vC0 and iL0, and produces a pair (using cons) of the streams of states vC and iL. Using RLC, generate the pair of streams that models the behavior of a series RLC circuit with R = 1 ohm, C = 0.2 farad, L = 1 henry, dt = 0.1 second, and initial values iL0 = 0 amps and vC0 = 10 volts.
+(define (RLC R L C dt)
+ (lambda (vC0 iL0)
+ (define iL (integral (mydelay diL) iL0 dt))
+ (define dvC (scale-stream iL (/ -1 C)))
+ (define vC (integral (mydelay dvC) vC0 dt))
+ (define diL (add-streams (scale-stream vC (/ 1 L))
+ (scale-stream iL (/ R L -1))))
+ (cons vC iL)))
+
+(define sample-rlc ((RLC 1 1 0.2 0.1) 10 0))
+(display-streams 30 (car sample-rlc) (cdr sample-rlc))
blob - /dev/null
blob + d2ae4f3e4799583534b69490aeae9e93e1c9890c (mode 644)
--- /dev/null
+++ ex3-80.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (sqrt x tolerance)
+ (stream-limit (sqrt-stream x) tolerance))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+(define (integral delayed-integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (add-streams (scale-stream integrand dt)
+ int))))
+ int)
+
+(define (solve-2nd a b y0 dy0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (integral (mydelay ddy) dy0 dt))
+ (define ddy (add-streams (scale-stream dy a)
+ (scale-stream y b)))
+ y)
+
+;; Exercise 3.79. Generalize the solve-2nd procedure of exercise 3.78 so that it can be used to solve general second-order differential equations d2 y/dt2 = f(dy/dt, y).
+
+(define (solve-2nd f y0 dy0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (integral (mydelay ddy) dy0 dt))
+ (define ddy (stream-map f dy y))
+ y)
blob - /dev/null
blob + cefa2c5552d160140d7434f56f487b6e8c1dab08 (mode 644)
--- /dev/null
+++ ex3-81-2.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+(define (integral delayed-integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (add-streams (scale-stream integrand dt)
+ int))))
+ int)
+
+;; (define rand
+;; (let ((x random-init))
+;; (lambda ()
+;; (set! x (rand-update x))
+;; x)))
+
+;; (define (rand-update x)
+;; (let ((a (expt 2 32))
+;; (c 1103515245)
+;; (m 12345))
+;; (modulo (+ (* a x) c) m)))
+;; (define random-init 137)
+
+
+;; (define random-numbers
+;; (cons-stream random-init
+;; (stream-map rand-update random-numbers)))
+
+;; (define (map-successive-pairs f s)
+;; (cons-stream
+;; (f (stream-car s) (stream-car (stream-cdr s)))
+;; (map-successive-pairs f (stream-cdr (stream-cdr s)))))
+
+;; (define cesaro-stream
+;; (map-successive-pairs (lambda (r1 r2)
+;; (= (gcd r1 r2) 1))
+;; random-numbers))
+
+;; (define (monte-carlo experiment-stream pass fail)
+;; (define (next pass fail)
+;; (cons-stream
+;; (/ pass (+ pass fail))
+;; (monte-carlo
+;; (stream-cdr experiment-stream) pass fail)))
+;; (if (stream-car experiment-stream)
+;; (next (+ pass 1) fail)
+;; (next pass (+ fail 1))))
+
+;; (define pi (stream-map (lambda (p) (sqrt (/ 6.0 p)))
+;; (monte-carlo cesaro-stream 0 0)))
+;; (display-streams 100 pi)
+
+;; Exercise 3.81. Exercise 3.6 discussed generalizing the random-number generator to allow one to reset the random-number sequence so as to produce repeatable sequences of ``random'' numbers. Produce a stream formulation of this same generator that operates on an input stream of requests to generate a new random number or to reset the sequence to a specified value and that produces the desired stream of random numbers. Don't use assignment in your solution.
+
+;;(define (rand-update x)
+;; (randomize x)
+;; (random (expt 2 31)))
+(define (rand-update x)
+ (let ((a (expt 2 32))
+ (c 1103515245)
+ (m 12345))
+ (modulo (+ (* a x) c) m)))
+(define initial-seed 12392)
+(rand-update initial-seed)
+
+
+(define (random-number-generator commands)
+ (define (choose seed command)
+ (if (and (pair? command) (eq? (car command) 'reset))
+ (rand-update (cadr command))
+ (rand-update seed)))
+ (if (stream-null? commands)
+ the-empty-stream
+ (cons-stream
+ (choose (rand-update initial-seed) (stream-car commands))
+ (stream-map choose
+ (random-number-generator commands)
+ commands))))
+
+(define random-commands '(gen gen gen gen gen (reset 137) gen gen gen (reset 293123) gen gen gen gen (reset 293123) gen gen gen gen (reset 137) gen gen gen gen gen gen))
+(define random-numbers (random-number-generator (list->stream random-commands)))
+
+(test-stream-list random-numbers random-commands)
+
+;; this actually has a delay after reset, so it's not ideal
blob - /dev/null
blob + eebcf385fa7b784c7d45b8300075a73ecb2d1740 (mode 644)
--- /dev/null
+++ ex3-81-2.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+(define (integral delayed-integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (add-streams (scale-stream integrand dt)
+ int))))
+ int)
+
+;; (define rand
+;; (let ((x random-init))
+;; (lambda ()
+;; (set! x (rand-update x))
+;; x)))
+
+;; (define (rand-update x)
+;; (let ((a (expt 2 32))
+;; (c 1103515245)
+;; (m 12345))
+;; (modulo (+ (* a x) c) m)))
+;; (define random-init 137)
+
+
+;; (define random-numbers
+;; (cons-stream random-init
+;; (stream-map rand-update random-numbers)))
+
+;; (define (map-successive-pairs f s)
+;; (cons-stream
+;; (f (stream-car s) (stream-car (stream-cdr s)))
+;; (map-successive-pairs f (stream-cdr (stream-cdr s)))))
+
+;; (define cesaro-stream
+;; (map-successive-pairs (lambda (r1 r2)
+;; (= (gcd r1 r2) 1))
+;; random-numbers))
+
+;; (define (monte-carlo experiment-stream pass fail)
+;; (define (next pass fail)
+;; (cons-stream
+;; (/ pass (+ pass fail))
+;; (monte-carlo
+;; (stream-cdr experiment-stream) pass fail)))
+;; (if (stream-car experiment-stream)
+;; (next (+ pass 1) fail)
+;; (next pass (+ fail 1))))
+
+;; (define pi (stream-map (lambda (p) (sqrt (/ 6.0 p)))
+;; (monte-carlo cesaro-stream 0 0)))
+;; (display-streams 100 pi)
+
+;; Exercise 3.81. Exercise 3.6 discussed generalizing the random-number generator to allow one to reset the random-number sequence so as to produce repeatable sequences of ``random'' numbers. Produce a stream formulation of this same generator that operates on an input stream of requests to generate a new random number or to reset the sequence to a specified value and that produces the desired stream of random numbers. Don't use assignment in your solution.
+
+;;(define (rand-update x)
+;; (randomize x)
+;; (random (expt 2 31)))
+(define (rand-update x)
+ (let ((a (expt 2 32))
+ (c 1103515245)
+ (m 12345))
+ (modulo (+ (* a x) c) m)))
+(define initial-seed 12392)
+(rand-update initial-seed)
+
+
+(define (random-number-generator commands)
+ (define (choose seed command)
+ (if (and (pair? command) (eq? (car command) 'reset))
+ (rand-update (cadr command))
+ (rand-update seed)))
+ (if (stream-null? commands)
+ the-empty-stream
+ (cons-stream (choose initial-seed (stream-car commands))
+ (stream-map choose
+ (random-number-generator (stream-cdr commands))
+ (stream-cdr commands)))))
+
+(define random-commands '(gen gen gen gen gen (reset 137) gen gen gen (reset 293123) gen gen gen gen (reset 293123) gen gen gen gen (reset 137) gen gen gen gen gen gen))
+(define random-numbers (random-number-generator (list->stream random-commands)))
+
+(test-stream-list random-numbers random-commands)
blob - /dev/null
blob + eebcf385fa7b784c7d45b8300075a73ecb2d1740 (mode 644)
--- /dev/null
+++ ex3-81.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+(define (integral delayed-integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (add-streams (scale-stream integrand dt)
+ int))))
+ int)
+
+;; (define rand
+;; (let ((x random-init))
+;; (lambda ()
+;; (set! x (rand-update x))
+;; x)))
+
+;; (define (rand-update x)
+;; (let ((a (expt 2 32))
+;; (c 1103515245)
+;; (m 12345))
+;; (modulo (+ (* a x) c) m)))
+;; (define random-init 137)
+
+
+;; (define random-numbers
+;; (cons-stream random-init
+;; (stream-map rand-update random-numbers)))
+
+;; (define (map-successive-pairs f s)
+;; (cons-stream
+;; (f (stream-car s) (stream-car (stream-cdr s)))
+;; (map-successive-pairs f (stream-cdr (stream-cdr s)))))
+
+;; (define cesaro-stream
+;; (map-successive-pairs (lambda (r1 r2)
+;; (= (gcd r1 r2) 1))
+;; random-numbers))
+
+;; (define (monte-carlo experiment-stream pass fail)
+;; (define (next pass fail)
+;; (cons-stream
+;; (/ pass (+ pass fail))
+;; (monte-carlo
+;; (stream-cdr experiment-stream) pass fail)))
+;; (if (stream-car experiment-stream)
+;; (next (+ pass 1) fail)
+;; (next pass (+ fail 1))))
+
+;; (define pi (stream-map (lambda (p) (sqrt (/ 6.0 p)))
+;; (monte-carlo cesaro-stream 0 0)))
+;; (display-streams 100 pi)
+
+;; Exercise 3.81. Exercise 3.6 discussed generalizing the random-number generator to allow one to reset the random-number sequence so as to produce repeatable sequences of ``random'' numbers. Produce a stream formulation of this same generator that operates on an input stream of requests to generate a new random number or to reset the sequence to a specified value and that produces the desired stream of random numbers. Don't use assignment in your solution.
+
+;;(define (rand-update x)
+;; (randomize x)
+;; (random (expt 2 31)))
+(define (rand-update x)
+ (let ((a (expt 2 32))
+ (c 1103515245)
+ (m 12345))
+ (modulo (+ (* a x) c) m)))
+(define initial-seed 12392)
+(rand-update initial-seed)
+
+
+(define (random-number-generator commands)
+ (define (choose seed command)
+ (if (and (pair? command) (eq? (car command) 'reset))
+ (rand-update (cadr command))
+ (rand-update seed)))
+ (if (stream-null? commands)
+ the-empty-stream
+ (cons-stream (choose initial-seed (stream-car commands))
+ (stream-map choose
+ (random-number-generator (stream-cdr commands))
+ (stream-cdr commands)))))
+
+(define random-commands '(gen gen gen gen gen (reset 137) gen gen gen (reset 293123) gen gen gen gen (reset 293123) gen gen gen gen (reset 137) gen gen gen gen gen gen))
+(define random-numbers (random-number-generator (list->stream random-commands)))
+
+(test-stream-list random-numbers random-commands)
blob - /dev/null
blob + 7f8ae1720ec2114011d9223f34815308b54919d6 (mode 644)
--- /dev/null
+++ ex3-81.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+(define (integral delayed-integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (add-streams (scale-stream integrand dt)
+ int))))
+ int)
+
+;; (define rand
+;; (let ((x random-init))
+;; (lambda ()
+;; (set! x (rand-update x))
+;; x)))
+
+;; (define (rand-update x)
+;; (let ((a (expt 2 32))
+;; (c 1103515245)
+;; (m 12345))
+;; (modulo (+ (* a x) c) m)))
+;; (define random-init 137)
+
+(define random-init 317)
+(define (rand-update x)
+ (random (expt 2 31)))
+
+(define random-numbers
+ (cons-stream random-init
+ (stream-map rand-update random-numbers)))
+(define (map-successive-pairs f s)
+ (cons-stream
+ (f (stream-car s) (stream-car (stream-cdr s)))
+ (map-successive-pairs f (stream-cdr (stream-cdr s)))))
+
+(define cesaro-stream
+ (map-successive-pairs (lambda (r1 r2) (= (gcd r1 r2) 1))
+ random-numbers))
+
+(define (monte-carlo experiment-stream passed failed)
+ (define (next passed failed)
+ (cons-stream
+ (/ passed (+ passed failed))
+ (monte-carlo
+ (stream-cdr experiment-stream) passed failed)))
+ (if (stream-car experiment-stream)
+ (next (+ passed 1) failed)
+ (next passed (+ failed 1))))
+
+(define pi
+ (stream-map (lambda (p) (sqrt (/ 6 p)))
+ (monte-carlo cesaro-stream 0 0)))
+(display-streams 10000 pi)
blob - /dev/null
blob + 29d8b47d0bd11bc7814f6d44a03e0ae50a5645c3 (mode 644)
--- /dev/null
+++ ex3-82.scm
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+(define (integral delayed-integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (add-streams (scale-stream integrand dt)
+ int))))
+ int)
+
+;; (define rand
+;; (let ((x random-init))
+;; (lambda ()
+;; (set! x (rand-update x))
+;; x)))
+
+;; (define (rand-update x)
+;; (let ((a (expt 2 32))
+;; (c 1103515245)
+;; (m 12345))
+;; (modulo (+ (* a x) c) m)))
+;; (define random-init 137)
+
+
+
+(define (map-successive-pairs f s)
+ (cons-stream
+ (f (stream-car s) (stream-car (stream-cdr s)))
+ (map-successive-pairs f (stream-cdr (stream-cdr s)))))
+
+;; (define cesaro-stream
+;; (map-successive-pairs (lambda (r1 r2)
+;; (= (gcd r1 r2) 1))
+;; random-numbers))
+
+(define initial-seed 317)
+(define (rand-update x)
+ (/ (random (expt 2.0 31))
+ (expt 2.0 31)))
+
+(define random-decimals
+ (cons-stream (rand-update initial-seed)
+ (stream-map rand-update random-numbers)))
+
+
+(define (monte-carlo experiment-stream pass fail)
+ (define (next pass fail)
+ (cons-stream
+ (/ pass (+ pass fail))
+ (monte-carlo
+ (stream-cdr experiment-stream) pass fail)))
+ (if (stream-car experiment-stream)
+ (next (+ pass 1) fail)
+ (next pass (+ fail 1))))
+
+;; (define pi (stream-map (lambda (p) (sqrt (/ 6.0 p)))
+;; (monte-carlo cesaro-stream 0 0)))
+;; (display-streams 100 pi)
+
+;; Exercise 3.82. Redo exercise 3.5 on Monte Carlo integration in terms of streams. The stream version of estimate-integral will not have an argument telling how many trials to perform. Instead, it will produce a stream of estimates based on successively more trials.
+
+
+;; (display-streams 100 random-decimals)
+
+(define (estimate-integral x1 y1 x2 y2 P)
+ (let ((x (- x2 x1))
+ (y (- y2 y1)))
+ (define xy-stream
+ (map-successive-pairs
+ (lambda (r1 r2)
+ (list (+ x1 (* x r1))
+ (+ y1 (* y r2))))
+ random-decimals))
+ (define inside-stream
+ (stream-map
+ (lambda (pair)
+ (P (car pair) (cadr pair)))
+ xy-stream))
+ (define estimate-stream
+ (stream-map
+ (lambda (p)
+ (* p x y))
+ (monte-carlo inside-stream 0 0)))
+ estimate-stream))
+
+(define area-estimate
+ (estimate-integral 2 4 8 10
+ (lambda (x y)
+ (<= (+ (square (- x 5))
+ (square (- y 7)))
+ 9.0))))
+
+(test-case (exact->inexact (stream-ref area-estimate 10000)) 28.27433)
+;; the exact area is 9pi = 28.2743339, so this is pretty close
blob - /dev/null
blob + cefa2c5552d160140d7434f56f487b6e8c1dab08 (mode 644)
--- /dev/null
+++ ex3-82.scm~
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+
+(define (stream-ref s n)
+ (if (= n 0)
+ (stream-car s)
+ (stream-ref (stream-cdr s) (- n 1))))
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+
+(define (stream-enumerate-interval low high)
+ (if (> low high)
+ the-empty-stream
+ (cons-stream
+ low
+ (stream-enumerate-interval (+ low 1) high))))
+(define (stream-filter pred s)
+ (if (stream-null? s)
+ the-empty-stream
+ (let ((scar (stream-car s)))
+ (if (pred scar)
+ (cons-stream scar (stream-filter pred (stream-cdr s)))
+ (stream-filter pred (stream-cdr s))))))
+
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (integers-starting-from n)
+ (cons-stream n (integers-starting-from (+ n 1))))
+(define integers (integers-starting-from 1))
+
+(define (divisible? x y) (= (remainder x y) 0))
+
+(define (fibgen a b)
+ (cons-stream a (fibgen b (+ a b))))
+(define fibs (fibgen 0 1))
+
+(define (sieve s)
+ (cons-stream
+ (stream-car s)
+ (sieve (stream-filter
+ (lambda (x)
+ (not (divisible? x (stream-car s))))
+ (stream-cdr s)))))
+
+(define ones (cons-stream 1 ones))
+(define (add-streams s1 s2)
+ (stream-map + s1 s2))
+(define integers (cons-stream 1 (add-streams ones integers)))
+
+(define fibs
+ (cons-stream 0
+ (cons-stream 1
+ (add-streams (stream-cdr fibs)
+ fibs))))
+
+(define (scale-stream stream factor)
+ (stream-map (lambda (x)
+ (* x factor))
+ stream))
+
+(define primes
+ (cons-stream
+ 2
+ (stream-filter prime? (integers-starting-from 3))))
+(define (prime? n)
+ (define (iter ps)
+ (cond ((> (square (stream-car ps)) n) true)
+ ((divisible? n (stream-car ps)) false)
+ (else (iter (stream-cdr ps)))))
+ (iter primes))
+
+(define (mul-streams s1 s2)
+ (stream-map * s1 s2))
+
+(define (partial-sums s)
+ (define sums
+ (cons-stream (stream-car s)
+ (add-streams sums
+ (stream-cdr s))))
+ sums)
+
+(define (merge s1 s2)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (cond ((< s1car s2car)
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) s2)))
+ ((> s1car s2car)
+ (cons-stream
+ s2car
+ (merge s1 (stream-cdr s2))))
+ (else
+ (cons-stream
+ s1car
+ (merge (stream-cdr s1) (stream-cdr s2)))))))))
+
+(define (test-stream-list stream list)
+ (if (null? list)
+ 'done
+ (begin (display "A: ")
+ (display (stream-car stream))
+ (display " -- ")
+ (display "E: ")
+ (display (car list))
+ (newline)
+ (test-stream-list (stream-cdr stream) (cdr list)))))
+
+(define (integrate-series a)
+ (stream-map / a integers))
+
+(define exp-series
+ (cons-stream 1 (integrate-series exp-series)))
+
+(define cosine-series
+ (cons-stream
+ 1
+ (integrate-series (stream-map - sine-series))))
+(define sine-series
+ (cons-stream
+ 0
+ (integrate-series cosine-series)))
+
+(define (mul-series s1 s2)
+ (cons-stream
+ (* (stream-car s1) (stream-car s2))
+ (add-streams
+ (scale-stream (stream-cdr s2) (stream-car s1))
+ (mul-series (stream-cdr s1) s2))))
+
+(define (invert-unit-series s)
+ (define x
+ (cons-stream
+ 1
+ (mul-series (stream-map - (stream-cdr s))
+ x)))
+ x)
+
+(define (div-series num den)
+ (let ((den-car (stream-car den)))
+ (if (zero? den-car)
+ (error "Denominator has zero constant term -- DIV-SERIES")
+ (scale-stream
+ (mul-series
+ num
+ (invert-unit-series (scale-stream den (/ 1 den-car))))
+ (/ 1 den-car)))))
+
+
+(define (sqrt-improve guess x)
+ (define (average x y)
+ (/ (+ x y) 2))
+ (average guess (/ x guess)))
+
+(define (sqrt-stream x)
+ (define guesses
+ (cons-stream
+ 1
+ (stream-map (lambda (guess)
+ (sqrt-improve guess x))
+ guesses)))
+ guesses)
+
+(define (pi-summands n)
+ (cons-stream (/ 1 n)
+ (stream-map - (pi-summands (+ n 2)))))
+(define pi-stream
+ (scale-stream (partial-sums (pi-summands 1)) 4))
+
+(define (euler-transform s)
+ (let ((s0 (stream-ref s 0))
+ (s1 (stream-ref s 1))
+ (s2 (stream-ref s 2)))
+ (cons-stream
+ (- s2 (/ (square (- s2 s1))
+ (+ s0 (* -2 s1) s2)))
+ (euler-transform (stream-cdr s)))))
+
+(define (make-tableau transform s)
+ (cons-stream s
+ (make-tableau transform
+ (transform s))))
+
+(define (stream-limit s tol)
+ (let* ((scar (stream-car s))
+ (scdr (stream-cdr s))
+ (scadr (stream-car scdr)))
+ (if (< (abs (- scar scadr)) tol)
+ scadr
+ (stream-limit scdr tol))))
+
+(define (pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (pairs (stream-cdr s) (stream-cdr t)))))
+(define (interleave s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (interleave s2 (stream-cdr s1)))))
+
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+
+(define (all-pairs s t)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list x (stream-car t)))
+ (stream-cdr s))
+ (interleave
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (all-pairs (stream-cdr s) (stream-cdr t))))))
+
+(define (triples s t u)
+ (cons-stream
+ (list (stream-car s) (stream-car t) (stream-car u))
+ (interleave
+ (stream-cdr (stream-map (lambda (pair)
+ (cons (stream-car s) pair))
+ (pairs t u)))
+ (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
+
+(define pythag-triples
+ (stream-filter
+ (lambda (triple)
+ (let ((i (car triple))
+ (j (cadr triple))
+ (k (caddr triple)))
+ (= (square k) (+ (square i) (square j)))))
+ (triples integers integers integers)))
+
+(define (merge-weighted s1 s2 weight)
+ (cond ((stream-null? s1) s2)
+ ((stream-null? s2) s1)
+ (else
+ (let ((s1car (stream-car s1))
+ (s2car (stream-car s2)))
+ (if (<= (weight s1car) (weight s2car))
+ (cons-stream
+ s1car
+ (merge-weighted (stream-cdr s1) s2 weight))
+ (cons-stream
+ s2car
+ (merge-weighted s1 (stream-cdr s2) weight)))))))
+
+(define (weighted-pairs s t weight)
+ (cons-stream
+ (list (stream-car s) (stream-car t))
+ (merge-weighted
+ (stream-map
+ (lambda (x)
+ (list (stream-car s) x))
+ (stream-cdr t))
+ (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
+ weight)))
+
+(define (integral integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (add-streams (scale-stream integrand dt)
+ int)))
+ int)
+
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+(define (solve f y0 dt)
+ (define y (integral (mydelay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+(define (integral delayed-integrand initial-value dt)
+ (define int
+ (cons-stream initial-value
+ (let ((integrand (myforce delayed-integrand)))
+ (add-streams (scale-stream integrand dt)
+ int))))
+ int)
+
+;; (define rand
+;; (let ((x random-init))
+;; (lambda ()
+;; (set! x (rand-update x))
+;; x)))
+
+;; (define (rand-update x)
+;; (let ((a (expt 2 32))
+;; (c 1103515245)
+;; (m 12345))
+;; (modulo (+ (* a x) c) m)))
+;; (define random-init 137)
+
+
+;; (define random-numbers
+;; (cons-stream random-init
+;; (stream-map rand-update random-numbers)))
+
+;; (define (map-successive-pairs f s)
+;; (cons-stream
+;; (f (stream-car s) (stream-car (stream-cdr s)))
+;; (map-successive-pairs f (stream-cdr (stream-cdr s)))))
+
+;; (define cesaro-stream
+;; (map-successive-pairs (lambda (r1 r2)
+;; (= (gcd r1 r2) 1))
+;; random-numbers))
+
+;; (define (monte-carlo experiment-stream pass fail)
+;; (define (next pass fail)
+;; (cons-stream
+;; (/ pass (+ pass fail))
+;; (monte-carlo
+;; (stream-cdr experiment-stream) pass fail)))
+;; (if (stream-car experiment-stream)
+;; (next (+ pass 1) fail)
+;; (next pass (+ fail 1))))
+
+;; (define pi (stream-map (lambda (p) (sqrt (/ 6.0 p)))
+;; (monte-carlo cesaro-stream 0 0)))
+;; (display-streams 100 pi)
+
+;; Exercise 3.81. Exercise 3.6 discussed generalizing the random-number generator to allow one to reset the random-number sequence so as to produce repeatable sequences of ``random'' numbers. Produce a stream formulation of this same generator that operates on an input stream of requests to generate a new random number or to reset the sequence to a specified value and that produces the desired stream of random numbers. Don't use assignment in your solution.
+
+;;(define (rand-update x)
+;; (randomize x)
+;; (random (expt 2 31)))
+(define (rand-update x)
+ (let ((a (expt 2 32))
+ (c 1103515245)
+ (m 12345))
+ (modulo (+ (* a x) c) m)))
+(define initial-seed 12392)
+(rand-update initial-seed)
+
+
+(define (random-number-generator commands)
+ (define (choose seed command)
+ (if (and (pair? command) (eq? (car command) 'reset))
+ (rand-update (cadr command))
+ (rand-update seed)))
+ (if (stream-null? commands)
+ the-empty-stream
+ (cons-stream
+ (choose (rand-update initial-seed) (stream-car commands))
+ (stream-map choose
+ (random-number-generator commands)
+ commands))))
+
+(define random-commands '(gen gen gen gen gen (reset 137) gen gen gen (reset 293123) gen gen gen gen (reset 293123) gen gen gen gen (reset 137) gen gen gen gen gen gen))
+(define random-numbers (random-number-generator (list->stream random-commands)))
+
+(test-stream-list random-numbers random-commands)
+
+;; this actually has a delay after reset, so it's not ideal
blob - /dev/null
blob + b874d7777d006346a35fe4db686a2c0d7b56920d (mode 644)
--- /dev/null
+++ ex4-1-2.scm
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (cons (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+
+;; Exercise 4.1. Notice that we cannot tell whether the metacircular evaluator evaluates operands from left to right or from right to left. Its evaluation order is inherited from the underlying Lisp: If the arguments to cons in list-of-values are evaluated from left to right, then list-of-values will evaluate operands from left to right; and if the arguments to cons are evaluated from right to left, then list-of-values will evaluate operands from right to left.
+
+;; Write a version of list-of-values that evaluates operands from left to right regardless of the order of evaluation in the underlying Lisp. Also write a version of list-of-values that evaluates operands from right to left.
+
+(define (list-of-values-l->r exps env)
+ (if (no-operands? exps)
+ '()
+ (let* ((first (eval (first-operand exps) env))
+ (rest (list-of-values (rest-operands exps) env)))
+ (cons first rest))))
+(define (list-of-values-r->l exps env)
+ (if (no-operands? exps)
+ '()
+ (let* ((rest (list-of-values (rest-operands exps) env))
+ (first (eval (first-operand exps) env)))
+ (cons first rest))))
+
+(geval
+ '(define old-value
+ (let ((x 0))
+ (lambda (y)
+ (let ((z x))
+ (set! x y)
+ z)))))
+
+(define list-of-values list-of-values-l->r)
+(test-case (geval '(+ (old-value 4) (old-value 5)))
+ 4)
+(test-case (geval '(- (old-value 2) (old-value 8)))
+ 3)
+(define list-of-values list-of-values-r->l)
+(test-case (geval '(+ (old-value 4) (old-value 5)))
+ 13)
+(test-case (geval '(- (old-value 2) (old-value 8)))
+ 4)
+
+
+;; eval test suite
+;; (test-case (geval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y))))
+;; (+ 4 7 (* 4 7)))
blob - /dev/null
blob + c72bd7636f76316aa52b61af35a7412f3475af91 (mode 644)
--- /dev/null
+++ ex4-1-2.scm~
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; Exercise 4.1. Notice that we cannot tell whether the metacircular evaluator evaluates operands from left to right or from right to left. Its evaluation order is inherited from the underlying Lisp: If the arguments to cons in list-of-values are evaluated from left to right, then list-of-values will evaluate operands from left to right; and if the arguments to cons are evaluated from right to left, then list-of-values will evaluate operands from right to left.
+
+;; Write a version of list-of-values that evaluates operands from left to right regardless of the order of evaluation in the underlying Lisp. Also write a version of list-of-values that evaluates operands from right to left.
+
+
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (cons (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; eval test suite
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(geval
+ '(define old-value
+ (let ((x 0))
+ (lambda (y)
+ (let ((z x))
+ (set! x y)
+ z)))))
+
+
+(test-case (geval '(+ (old-value 4) (old-value 5)))
+ 4)
+(test-case (geval '(- (old-value 2) (old-value 8)))
+ 3)
+
blob - /dev/null
blob + c72bd7636f76316aa52b61af35a7412f3475af91 (mode 644)
--- /dev/null
+++ ex4-1.scm
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; Exercise 4.1. Notice that we cannot tell whether the metacircular evaluator evaluates operands from left to right or from right to left. Its evaluation order is inherited from the underlying Lisp: If the arguments to cons in list-of-values are evaluated from left to right, then list-of-values will evaluate operands from left to right; and if the arguments to cons are evaluated from right to left, then list-of-values will evaluate operands from right to left.
+
+;; Write a version of list-of-values that evaluates operands from left to right regardless of the order of evaluation in the underlying Lisp. Also write a version of list-of-values that evaluates operands from right to left.
+
+
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (cons (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; eval test suite
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(geval
+ '(define old-value
+ (let ((x 0))
+ (lambda (y)
+ (let ((z x))
+ (set! x y)
+ z)))))
+
+
+(test-case (geval '(+ (old-value 4) (old-value 5)))
+ 4)
+(test-case (geval '(- (old-value 2) (old-value 8)))
+ 3)
+
blob - /dev/null
blob + d8da0a4c788407fe1fa285ea485d2f022cfc464b (mode 644)
--- /dev/null
+++ ex4-1.scm~
+(define apply-in-underlying-scheme apply)
+(define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ <more primitives>
+ ))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; Exercise 4.1. Notice that we cannot tell whether the metacircular evaluator evaluates operands from left to right or from right to left. Its evaluation order is inherited from the underlying Lisp: If the arguments to cons in list-of-values are evaluated from left to right, then list-of-values will evaluate operands from left to right; and if the arguments to cons are evaluated from right to left, then list-of-values will evaluate operands from right to left.
+
+;; Write a version of list-of-values that evaluates operands from left to right regardless of the order of evaluation in the underlying Lisp. Also write a version of list-of-values that evaluates operands from right to left.
+
+;; Exercise 4.6. Let expressions are derived expressions, because
+
+(let ((<var1> <exp1>) ... (<varn> <expn>))
+ <body>)
+
+;; is equivalent to
+
+((lambda (<var1> ... <varn>)
+ <body>)
+ <exp1>
+
+ <expn>)
+
+;; Implement a syntactic transformation let->combination that reduces evaluating let expressions to evaluating combinations of the type shown above, and add the appropriate clause to eval to handle let expressions.
+
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (cons (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(eval '(define old-value
+ (let ((x 0))
+ (lambda (y)
+ (let ((z x))
+ (set! x y)
+ z))))
+ the-global-environment)
+(eval '
+(define (print
+
+(eval-test-case '((old-value 5) (old-value 3)
blob - /dev/null
blob + 86a3ff4d8a1387d308995d1e4acf033ef4352203 (mode 644)
--- /dev/null
+++ ex4-10.scm
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
blob - /dev/null
blob + 406f448f51001f2cb20d1bb598f8457f15c5b911 (mode 644)
--- /dev/null
+++ ex4-10.scm~
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.9. Many languages support a variety of iteration constructs, such as do, for, while, and until. In Scheme, iterative processes can be expressed in terms of ordinary procedure calls, so special iteration constructs provide no essential gain in computational power. On the other hand, such constructs are often convenient. Design some iteration constructs, give examples of their use, and show how to implement them as derived expressions.
+
+;; Implemented according to this spec:
+;; http://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Iteration.html
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
blob - /dev/null
blob + 93692bc21b72cff6999d9263b3acec1e71b1ade6 (mode 644)
--- /dev/null
+++ ex4-11.scm
+(define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (map cons variables values))
+;; (define (set-first-frame! env frame)
+;; (set-car! env frame))
+(define (binding-var binding)
+ (car binding))
+(define (binding-val binding)
+ (cdr binding))
+(define (make-binding var val)
+ (cons var val))
+;; (define (frame-variables frame) (map car frame))
+;; (define (frame-values frame) (map cdr frame))
+(define (add-binding-to-first-frame! var val env)
+ (set-car! env (cons (make-binding var val) (first-frame env))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan bindings)
+ (cond ((null? bindings)
+ (env-loop (enclosing-environment env)))
+ ((eq? (binding-var (car bindings)) var)
+ (binding-val (car bindings)))
+ (else (scan (cdr bindings)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (scan (first-frame env))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan bindings)
+ (cond ((null? bindings)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (binding-var (car bindings)))
+ (set-cdr! (car bindings) val))
+ (else (scan (cdr bindings)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (scan (first-frame env))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan bindings)
+ (cond ((null? bindings)
+ (add-binding-to-first-frame! var val env))
+ ((eq? var (binding-var (car bindings)))
+ (set-cdr! (car bindings) val))
+ (else (scan (cdr bindings)))))
+ (scan (first-frame env))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.11. Instead of representing a frame as a pair of lists, we can represent a frame as a list of bindings, where each binding is a name-value pair. Rewrite the environment operations to use this alternative representation.
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
blob - /dev/null
blob + 86a3ff4d8a1387d308995d1e4acf033ef4352203 (mode 644)
--- /dev/null
+++ ex4-11.scm~
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
blob - /dev/null
blob + 0bd7268ee311b83fb426795e4c22d15dd553a0a6 (mode 644)
--- /dev/null
+++ ex4-12.scm
+(define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (env-loop var env found unbound)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop var (enclosing-environment env) found unbound))
+ ((eq? var (car vars))
+ (found vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (unbound)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+(define (lookup-variable-value var env)
+ (env-loop var env car (lambda ()
+ (error "Unbound variable" var))))
+(define (set-variable-value! var val env)
+ (env-loop var
+ env
+ (lambda (vals)
+ (set-car! vals val))
+ (lambda ()
+ (error "Unbound variable -- SET!" var))))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (env-loop var
+ (list frame)
+ (lambda (vals)
+ (set-car! vals val))
+ (lambda ()
+ (add-binding-to-frame! var val frame)))))
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.12. The procedures set-variable-value!, define-variable!, and lookup-variable-value can be expressed in terms of more abstract procedures for traversing the environment structure. Define abstractions that capture the common patterns and redefine the three procedures in terms of these abstractions.
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
blob - /dev/null
blob + 406f448f51001f2cb20d1bb598f8457f15c5b911 (mode 644)
--- /dev/null
+++ ex4-12.scm~
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.9. Many languages support a variety of iteration constructs, such as do, for, while, and until. In Scheme, iterative processes can be expressed in terms of ordinary procedure calls, so special iteration constructs provide no essential gain in computational power. On the other hand, such constructs are often convenient. Design some iteration constructs, give examples of their use, and show how to implement them as derived expressions.
+
+;; Implemented according to this spec:
+;; http://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Iteration.html
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
blob - /dev/null
blob + 5bee6877226d2713bd866c94264265e15c1e2918 (mode 644)
--- /dev/null
+++ ex4-13.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.13. Scheme allows us to create new bindings for variables by means of define, but provides no way to get rid of bindings. Implement for the evaluator a special form make-unbound! that removes the binding of a given symbol from the environment in which the make-unbound! expression is evaluated. This problem is not completely specified. For example, should we remove only the binding in the first frame of the environment? Complete the specification and justify any choices you make.
+
+;; we'll remove the binding only from the first frame of the environment in order to avoid remove bindings from other environments, which could potentially be confusing. For example:
+
+;; (let ((x 3) (y 4))
+;; ((lambda (z)
+;; (make-unbound! x)) 3)
+;; ((lambda ()
+;; (+ x 4))))
+
+;; if we were to remove bindings from other environments, then the first procedure would be able to unbind a variable which the second procedure depends on. It would break an environment extended from an enclosing environment
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
blob - /dev/null
blob + 9de8722a159278b74a186c2cbad5be12e7d6214a (mode 644)
--- /dev/null
+++ ex4-13.scm~
+(define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.13. Scheme allows us to create new bindings for variables by means of define, but provides no way to get rid of bindings. Implement for the evaluator a special form make-unbound! that removes the binding of a given symbol from the environment in which the make-unbound! expression is evaluated. This problem is not completely specified. For example, should we remove only the binding in the first frame of the environment? Complete the specification and justify any choices you make.
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
blob - /dev/null
blob + 40a897f18148f1bfa2e2d636df5f6527df1a8fcb (mode 644)
--- /dev/null
+++ ex4-14.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.14. Eva Lu Ator and Louis Reasoner are each experimenting with the metacircular evaluator. Eva types in the definition of map, and runs some test programs that use it. They work fine. Louis, in contrast, has installed the system version of map as a primitive for the metacircular evaluator. When he tries it, things go terribly wrong. Explain why Louis's map fails even though Eva's works.
+
+;; If map is a primitive procedure, then the 2nd argument which is passed to map is not something the underlying scheme can handle but is instead of the form '(procedure <params> <body> <env>) rather than the underlying scheme procedure objects.
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
blob - /dev/null
blob + 5bee6877226d2713bd866c94264265e15c1e2918 (mode 644)
--- /dev/null
+++ ex4-14.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.13. Scheme allows us to create new bindings for variables by means of define, but provides no way to get rid of bindings. Implement for the evaluator a special form make-unbound! that removes the binding of a given symbol from the environment in which the make-unbound! expression is evaluated. This problem is not completely specified. For example, should we remove only the binding in the first frame of the environment? Complete the specification and justify any choices you make.
+
+;; we'll remove the binding only from the first frame of the environment in order to avoid remove bindings from other environments, which could potentially be confusing. For example:
+
+;; (let ((x 3) (y 4))
+;; ((lambda (z)
+;; (make-unbound! x)) 3)
+;; ((lambda ()
+;; (+ x 4))))
+
+;; if we were to remove bindings from other environments, then the first procedure would be able to unbind a variable which the second procedure depends on. It would break an environment extended from an enclosing environment
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
blob - /dev/null
blob + c25b180f4839c2d26b8457f6a3b9777821699eef (mode 644)
--- /dev/null
+++ ex4-15.scm
+(define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.15. Given a one-argument procedure p and an object a, p is said to ``halt'' on a if evaluating the expression (p a) returns a value (as opposed to terminating with an error message or running forever). Show that it is impossible to write a procedure halts? that correctly determines whether p halts on a for any procedure p and object a. Use the following reasoning: If you had such a procedure halts?, you could implement the following program:
+
+(define (run-forever) (run-forever))
+
+(define (try p)
+ (if (halts? p p)
+ (run-forever)
+ 'halted))
+
+;; Now consider evaluating the expression (try try) and show that any possible outcome (either halting or running forever) violates the intended behavior of halts?.23
+
+;; If (try try) halts, (halts? try try) will be true. But then, according to the definition of try above, (try try) will run forever.
+
+;; On the other hand, if (try try) does not halt, then (halts? try try) will be false. However, according to the definition of try above, this means that (try try) will return 'halted and therefore halt.
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
blob - /dev/null
blob + f18cf424dec116a249bbeaf6a012243062d294ea (mode 644)
--- /dev/null
+++ ex4-15.scm~
+(define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.15. Given a one-argument procedure p and an object a, p is said to ``halt'' on a if evaluating the expression (p a) returns a value (as opposed to terminating with an error message or running forever). Show that it is impossible to write a procedure halts? that correctly determines whether p halts on a for any procedure p and object a. Use the following reasoning: If you had such a procedure halts?, you could implement the following program:
+
+(define (run-forever) (run-forever))
+
+(define (try p)
+ (if (halts? p p)
+ (run-forever)
+ 'halted))
+
+;; Now consider evaluating the expression (try try) and show that any possible outcome (either halting or running forever) violates the intended behavior of halts?.23
+
+If (try try)
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
blob - /dev/null
blob + 26819cccef276defc0591fb72fb1623c407bd88c (mode 644)
--- /dev/null
+++ ex4-16-2.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.16. In this exercise we implement the method just described for interpreting internal definitions. We assume that the evaluator supports let (see exercise 4.6).
+
+;; a. Change lookup-variable-value (section 4.1.3) to signal an error if the value it finds is the symbol *unassigned*.
+
+;; see above
+
+;; b. Write a procedure scan-out-defines that takes a procedure body and returns an equivalent one that has no internal definitions, by making the transformation described above.
+
+;; (lambda <vars>
+;; (define u <e1>)
+;; (define v <e2>)
+;; <e3>)
+
+;; would be transformed into
+
+;; (lambda <vars>
+;; (let ((u '*unassigned*)
+;; (v '*unassigned*))
+;; (set! u <e1>)
+;; (set! v <e2>)
+;; <e3>))
+
+;; (newline)
+;; (display "test")
+;; (newline)
+
+(define (make-assignment var val)
+ (list 'set! var val))
+
+(define (scan-out-defines body)
+ (define (scan-exps remaining-exps scanned-exps vars vals)
+ (if (null? remaining-exps)
+ (list (make-let vars
+ (map (lambda (var)
+ ''*unassigned*)
+ vars)
+ (append
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals)
+ scanned-exps)))
+ (let ((first (car remaining-exps))
+ (rest (cdr remaining-exps)))
+ (if (definition? first)
+ (scan-exps rest
+ scanned-exps
+ (append vars (list (definition-variable first)))
+ (append vals (list (definition-value first))))
+ (scan-exps rest
+ (append scanned-exps (list first))
+ vars
+ vals)))))
+ (scan-exps body '() '() '()))
+
+;; (filter definition? body)
+;; (remove definition? body)
+
+;; (define (make-let vars vals body)
+;; (cons 'let
+;; (cons (map list vars vals)
+;; body)))
+
+
+;; c. Install scan-out-defines in the interpreter, either in make-procedure or in procedure-body (see section 4.1.3). Which place is better? Why?
+
+;; better to put it in make-procedure. Otherwise, every time the procedure-body is requested for an application, we'd have to repeat the scanning. This would make applications quite slow and would be very inefficient.
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+(test-case
+ (scan-out-defines
+ '((define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+ '(let ((even? '*unassigned*)
+ (odd? '*unassigned*))
+ (set! even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (set! odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1)))))
+ (even? x)))
+
+((let ((even? (quote *unassigned*))
+ (odd? (quote *unassigned*)))
+ (set! even?
+ (lambda (n) (if (= n 0) true (odd? (- n 1)))))
+ (set! odd?
+ (lambda (n) (if (= n 0) false (even? (- n 1)))))
+ (even? x)))
+
+(geval
+ '(let ((x 5))
+ (define y x)
+ (define x 3)
+ (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
blob - /dev/null
blob + 5bee6877226d2713bd866c94264265e15c1e2918 (mode 644)
--- /dev/null
+++ ex4-16-2.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.13. Scheme allows us to create new bindings for variables by means of define, but provides no way to get rid of bindings. Implement for the evaluator a special form make-unbound! that removes the binding of a given symbol from the environment in which the make-unbound! expression is evaluated. This problem is not completely specified. For example, should we remove only the binding in the first frame of the environment? Complete the specification and justify any choices you make.
+
+;; we'll remove the binding only from the first frame of the environment in order to avoid remove bindings from other environments, which could potentially be confusing. For example:
+
+;; (let ((x 3) (y 4))
+;; ((lambda (z)
+;; (make-unbound! x)) 3)
+;; ((lambda ()
+;; (+ x 4))))
+
+;; if we were to remove bindings from other environments, then the first procedure would be able to unbind a variable which the second procedure depends on. It would break an environment extended from an enclosing environment
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
blob - /dev/null
blob + 4e06244f00b68a402b972ac02aa01e44d6a740a8 (mode 644)
--- /dev/null
+++ ex4-16-3.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.16. In this exercise we implement the method just described for interpreting internal definitions. We assume that the evaluator supports let (see exercise 4.6).
+
+;; a. Change lookup-variable-value (section 4.1.3) to signal an error if the value it finds is the symbol *unassigned*.
+
+;; see above
+
+;; b. Write a procedure scan-out-defines that takes a procedure body and returns an equivalent one that has no internal definitions, by making the transformation described above.
+
+;; (lambda <vars>
+;; (define u <e1>)
+;; (define v <e2>)
+;; <e3>)
+
+;; would be transformed into
+
+;; (lambda <vars>
+;; (let ((u '*unassigned*)
+;; (v '*unassigned*))
+;; (set! u <e1>)
+;; (set! v <e2>)
+;; <e3>))
+
+;; (newline)
+;; (display "test")
+;; (newline)
+
+(define (make-assignment var val)
+ (list 'set! var val))
+
+;; (define (scan-out-defines body)
+;; (define (scan-exps remaining-exps scanned-exps vars vals)
+;; (if (null? remaining-exps)
+;; (list (make-let vars
+;; (map (lambda (var)
+;; ''*unassigned*)
+;; vars)
+;; (append
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars
+;; vals)
+;; scanned-exps)))
+;; (let ((first (car remaining-exps))
+;; (rest (cdr remaining-exps)))
+;; (if (definition? first)
+;; (scan-exps rest
+;; scanned-exps
+;; (append vars (list (definition-variable first)))
+;; (append vals (list (definition-value first))))
+;; (scan-exps rest
+;; (append scanned-exps (list first))
+;; vars
+;; vals)))))
+;; (scan-exps body '() '() '()))
+
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps)))))
+
+
+;; ((let ((even? (quote *unassigned))
+;; (odd? (quote *unassigned)))
+;; (set! even?
+;; (lambda (n) (if (= n 0) true (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n) (if (= n 0) false (even? (- n 1)))))
+;; (even? x)))
+
+
+
+;; (define (make-let vars vals body)
+;; (cons 'let
+;; (cons (map list vars vals)
+;; body)))
+
+
+;; c. Install scan-out-defines in the interpreter, either in make-procedure or in procedure-body (see section 4.1.3). Which place is better? Why?
+
+;; better to put it in make-procedure. Otherwise, every time the procedure-body is requested for an application, we'd have to repeat the scanning. This would make applications quite slow and would be very inefficient.
+
+;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; (test-case
+;; (scan-out-defines
+;; '((define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; '(let ((even? '*unassigned*)
+;; (odd? '*unassigned*))
+;; (set! even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; (even? x)))
+
+;; ((let ((even? (quote *unassigned*))
+;; (odd? (quote *unassigned*)))
+;; (set! even?
+;; (lambda (n) (if (= n 0) true (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n) (if (= n 0) false (even? (- n 1)))))
+;; (even? x)))
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
blob - /dev/null
blob + 4e06244f00b68a402b972ac02aa01e44d6a740a8 (mode 644)
--- /dev/null
+++ ex4-16-3.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.16. In this exercise we implement the method just described for interpreting internal definitions. We assume that the evaluator supports let (see exercise 4.6).
+
+;; a. Change lookup-variable-value (section 4.1.3) to signal an error if the value it finds is the symbol *unassigned*.
+
+;; see above
+
+;; b. Write a procedure scan-out-defines that takes a procedure body and returns an equivalent one that has no internal definitions, by making the transformation described above.
+
+;; (lambda <vars>
+;; (define u <e1>)
+;; (define v <e2>)
+;; <e3>)
+
+;; would be transformed into
+
+;; (lambda <vars>
+;; (let ((u '*unassigned*)
+;; (v '*unassigned*))
+;; (set! u <e1>)
+;; (set! v <e2>)
+;; <e3>))
+
+;; (newline)
+;; (display "test")
+;; (newline)
+
+(define (make-assignment var val)
+ (list 'set! var val))
+
+;; (define (scan-out-defines body)
+;; (define (scan-exps remaining-exps scanned-exps vars vals)
+;; (if (null? remaining-exps)
+;; (list (make-let vars
+;; (map (lambda (var)
+;; ''*unassigned*)
+;; vars)
+;; (append
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars
+;; vals)
+;; scanned-exps)))
+;; (let ((first (car remaining-exps))
+;; (rest (cdr remaining-exps)))
+;; (if (definition? first)
+;; (scan-exps rest
+;; scanned-exps
+;; (append vars (list (definition-variable first)))
+;; (append vals (list (definition-value first))))
+;; (scan-exps rest
+;; (append scanned-exps (list first))
+;; vars
+;; vals)))))
+;; (scan-exps body '() '() '()))
+
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps)))))
+
+
+;; ((let ((even? (quote *unassigned))
+;; (odd? (quote *unassigned)))
+;; (set! even?
+;; (lambda (n) (if (= n 0) true (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n) (if (= n 0) false (even? (- n 1)))))
+;; (even? x)))
+
+
+
+;; (define (make-let vars vals body)
+;; (cons 'let
+;; (cons (map list vars vals)
+;; body)))
+
+
+;; c. Install scan-out-defines in the interpreter, either in make-procedure or in procedure-body (see section 4.1.3). Which place is better? Why?
+
+;; better to put it in make-procedure. Otherwise, every time the procedure-body is requested for an application, we'd have to repeat the scanning. This would make applications quite slow and would be very inefficient.
+
+;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; (test-case
+;; (scan-out-defines
+;; '((define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; '(let ((even? '*unassigned*)
+;; (odd? '*unassigned*))
+;; (set! even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; (even? x)))
+
+;; ((let ((even? (quote *unassigned*))
+;; (odd? (quote *unassigned*)))
+;; (set! even?
+;; (lambda (n) (if (= n 0) true (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n) (if (= n 0) false (even? (- n 1)))))
+;; (even? x)))
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
blob - /dev/null
blob + 1c59b0cec269cd80342936e144bb26e6255135da (mode 644)
--- /dev/null
+++ ex4-16-4.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (display "Evaluating: ")
+ (newline)
+ (user-print exps)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.16. In this exercise we implement the method just described for interpreting internal definitions. We assume that the evaluator supports let (see exercise 4.6).
+
+;; a. Change lookup-variable-value (section 4.1.3) to signal an error if the value it finds is the symbol *unassigned*.
+
+;; see above
+
+;; b. Write a procedure scan-out-defines that takes a procedure body and returns an equivalent one that has no internal definitions, by making the transformation described above.
+
+;; (lambda <vars>
+;; (define u <e1>)
+;; (define v <e2>)
+;; <e3>)
+
+;; would be transformed into
+
+;; (lambda <vars>
+;; (let ((u '*unassigned*)
+;; (v '*unassigned*))
+;; (set! u <e1>)
+;; (set! v <e2>)
+;; <e3>))
+
+;; (newline)
+;; (display "test")
+;; (newline)
+
+
+(define (make-assignment var val)
+ (list 'set! var val))
+
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+
+;; ((let ((even? (quote *unassigned*))
+;; (odd? (quote *unassigned*)))
+;; (set! even?
+;; (lambda (n)
+
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; (even? x)))
+
+
+
+
+;; c. Install scan-out-defines in the interpreter, either in make-procedure or in procedure-body (see section 4.1.3). Which place is better? Why?
+
+;; better to put it in make-procedure. Otherwise, every time the procedure-body is requested for an application, we'd have to repeat the scanning. This would make applications quite slow and would be very inefficient.
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (define f-proc (eval 'f the-global-environment))
+;; (procedure-body f-proc)
+;; ((let ((even? (quote *unassigned*)) (odd? (quote *unassigned*))) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x)))
+;; (user-print (procedure-body f-proc))
+;; ((let ((even? (quote *unassigned*)) (odd? (quote *unassigned*))) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x)))
+;; (first-exp (procedure-body f-proc))
+;; (let? (first-exp (procedure-body f-proc)))
+
+;Value: #t
+
+;; 1 ]=> (let->combination (first-exp (procedure-body f-proc)))
+
+;Value 14: ((lambda (even? odd?) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x)) (quote *unassigned*) (quote *unassigned*))
+
+
+;Value 13: (let ((even? (quote *unassigned*)) (odd? (quote *unassigned*))) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x))
+
+;; (operator (let->combination (first-exp (procedure-body f-proc))))
+
+;Value 15: (lambda (even? odd?) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x))
+
+;; 1 ]=> (lambda-parameters (operator (let->combination (first-exp (procedure-body f-proc)))))
+
+;Value 16: (even? odd?)
+
+;; ((set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x))
+
+;; there is an infinite loop going on
+;; the problem is that we scan out definitions and construct a let
+;; but, the let itself implies another lambda expression. To
+;; evaluate that lambda expression, we must construct another procedure.
+;; But then, we have to scan out *that* procedure. It never ends...
+
+;; (test-case
+;; (scan-out-defines
+;; '((define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; '(let ((even? '*unassigned*)
+;; (odd? '*unassigned*))
+;; (set! even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; (even? x)))
+
+;; ((let ((even? (quote *unassigned*))
+;; (odd? (quote *unassigned*)))
+;; (set! even?
+;; (lambda (n) (if (= n 0) true (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n) (if (= n 0) false (even? (- n 1)))))
+;; (even? x)))
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
blob - /dev/null
blob + 4e06244f00b68a402b972ac02aa01e44d6a740a8 (mode 644)
--- /dev/null
+++ ex4-16-4.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.16. In this exercise we implement the method just described for interpreting internal definitions. We assume that the evaluator supports let (see exercise 4.6).
+
+;; a. Change lookup-variable-value (section 4.1.3) to signal an error if the value it finds is the symbol *unassigned*.
+
+;; see above
+
+;; b. Write a procedure scan-out-defines that takes a procedure body and returns an equivalent one that has no internal definitions, by making the transformation described above.
+
+;; (lambda <vars>
+;; (define u <e1>)
+;; (define v <e2>)
+;; <e3>)
+
+;; would be transformed into
+
+;; (lambda <vars>
+;; (let ((u '*unassigned*)
+;; (v '*unassigned*))
+;; (set! u <e1>)
+;; (set! v <e2>)
+;; <e3>))
+
+;; (newline)
+;; (display "test")
+;; (newline)
+
+(define (make-assignment var val)
+ (list 'set! var val))
+
+;; (define (scan-out-defines body)
+;; (define (scan-exps remaining-exps scanned-exps vars vals)
+;; (if (null? remaining-exps)
+;; (list (make-let vars
+;; (map (lambda (var)
+;; ''*unassigned*)
+;; vars)
+;; (append
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars
+;; vals)
+;; scanned-exps)))
+;; (let ((first (car remaining-exps))
+;; (rest (cdr remaining-exps)))
+;; (if (definition? first)
+;; (scan-exps rest
+;; scanned-exps
+;; (append vars (list (definition-variable first)))
+;; (append vals (list (definition-value first))))
+;; (scan-exps rest
+;; (append scanned-exps (list first))
+;; vars
+;; vals)))))
+;; (scan-exps body '() '() '()))
+
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps)))))
+
+
+;; ((let ((even? (quote *unassigned))
+;; (odd? (quote *unassigned)))
+;; (set! even?
+;; (lambda (n) (if (= n 0) true (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n) (if (= n 0) false (even? (- n 1)))))
+;; (even? x)))
+
+
+
+;; (define (make-let vars vals body)
+;; (cons 'let
+;; (cons (map list vars vals)
+;; body)))
+
+
+;; c. Install scan-out-defines in the interpreter, either in make-procedure or in procedure-body (see section 4.1.3). Which place is better? Why?
+
+;; better to put it in make-procedure. Otherwise, every time the procedure-body is requested for an application, we'd have to repeat the scanning. This would make applications quite slow and would be very inefficient.
+
+;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; (test-case
+;; (scan-out-defines
+;; '((define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; '(let ((even? '*unassigned*)
+;; (odd? '*unassigned*))
+;; (set! even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; (even? x)))
+
+;; ((let ((even? (quote *unassigned*))
+;; (odd? (quote *unassigned*)))
+;; (set! even?
+;; (lambda (n) (if (= n 0) true (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n) (if (= n 0) false (even? (- n 1)))))
+;; (even? x)))
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
blob - /dev/null
blob + 1c59b0cec269cd80342936e144bb26e6255135da (mode 644)
--- /dev/null
+++ ex4-16-5.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (display "Evaluating: ")
+ (newline)
+ (user-print exps)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.16. In this exercise we implement the method just described for interpreting internal definitions. We assume that the evaluator supports let (see exercise 4.6).
+
+;; a. Change lookup-variable-value (section 4.1.3) to signal an error if the value it finds is the symbol *unassigned*.
+
+;; see above
+
+;; b. Write a procedure scan-out-defines that takes a procedure body and returns an equivalent one that has no internal definitions, by making the transformation described above.
+
+;; (lambda <vars>
+;; (define u <e1>)
+;; (define v <e2>)
+;; <e3>)
+
+;; would be transformed into
+
+;; (lambda <vars>
+;; (let ((u '*unassigned*)
+;; (v '*unassigned*))
+;; (set! u <e1>)
+;; (set! v <e2>)
+;; <e3>))
+
+;; (newline)
+;; (display "test")
+;; (newline)
+
+
+(define (make-assignment var val)
+ (list 'set! var val))
+
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+
+;; ((let ((even? (quote *unassigned*))
+;; (odd? (quote *unassigned*)))
+;; (set! even?
+;; (lambda (n)
+
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; (even? x)))
+
+
+
+
+;; c. Install scan-out-defines in the interpreter, either in make-procedure or in procedure-body (see section 4.1.3). Which place is better? Why?
+
+;; better to put it in make-procedure. Otherwise, every time the procedure-body is requested for an application, we'd have to repeat the scanning. This would make applications quite slow and would be very inefficient.
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (define f-proc (eval 'f the-global-environment))
+;; (procedure-body f-proc)
+;; ((let ((even? (quote *unassigned*)) (odd? (quote *unassigned*))) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x)))
+;; (user-print (procedure-body f-proc))
+;; ((let ((even? (quote *unassigned*)) (odd? (quote *unassigned*))) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x)))
+;; (first-exp (procedure-body f-proc))
+;; (let? (first-exp (procedure-body f-proc)))
+
+;Value: #t
+
+;; 1 ]=> (let->combination (first-exp (procedure-body f-proc)))
+
+;Value 14: ((lambda (even? odd?) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x)) (quote *unassigned*) (quote *unassigned*))
+
+
+;Value 13: (let ((even? (quote *unassigned*)) (odd? (quote *unassigned*))) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x))
+
+;; (operator (let->combination (first-exp (procedure-body f-proc))))
+
+;Value 15: (lambda (even? odd?) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x))
+
+;; 1 ]=> (lambda-parameters (operator (let->combination (first-exp (procedure-body f-proc)))))
+
+;Value 16: (even? odd?)
+
+;; ((set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x))
+
+;; there is an infinite loop going on
+;; the problem is that we scan out definitions and construct a let
+;; but, the let itself implies another lambda expression. To
+;; evaluate that lambda expression, we must construct another procedure.
+;; But then, we have to scan out *that* procedure. It never ends...
+
+;; (test-case
+;; (scan-out-defines
+;; '((define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; '(let ((even? '*unassigned*)
+;; (odd? '*unassigned*))
+;; (set! even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; (even? x)))
+
+;; ((let ((even? (quote *unassigned*))
+;; (odd? (quote *unassigned*)))
+;; (set! even?
+;; (lambda (n) (if (= n 0) true (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n) (if (= n 0) false (even? (- n 1)))))
+;; (even? x)))
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
blob - /dev/null
blob + 43b41e8a804d9d9b6f1792a584c61651644df888 (mode 644)
--- /dev/null
+++ ex4-16-6.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.16. In this exercise we implement the method just described for interpreting internal definitions. We assume that the evaluator supports let (see exercise 4.6).
+
+;; a. Change lookup-variable-value (section 4.1.3) to signal an error if the value it finds is the symbol *unassigned*.
+
+;; see above
+
+;; b. Write a procedure scan-out-defines that takes a procedure body and returns an equivalent one that has no internal definitions, by making the transformation described above.
+
+;; (lambda <vars>
+;; (define u <e1>)
+;; (define v <e2>)
+;; <e3>)
+
+;; would be transformed into
+
+;; (lambda <vars>
+;; (let ((u '*unassigned*)
+;; (v '*unassigned*))
+;; (set! u <e1>)
+;; (set! v <e2>)
+;; <e3>))
+
+;; (newline)
+;; (display "test")
+;; (newline)
+
+
+(define (make-assignment var val)
+ (list 'set! var val))
+
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+
+;; ((let ((even? (quote *unassigned*))
+;; (odd? (quote *unassigned*)))
+;; (set! even?
+;; (lambda (n)
+
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; (even? x)))
+
+
+
+
+;; c. Install scan-out-defines in the interpreter, either in make-procedure or in procedure-body (see section 4.1.3). Which place is better? Why?
+
+;; better to put it in make-procedure. Otherwise, every time the procedure-body is requested for an application, we'd have to repeat the scanning. This would make applications quite slow and would be very inefficient.
+
+;; N.B.: make-unbound! is now broken because the defines are scanned out. The problem is that if there are internal defines, the frames of the defines have been moved around.
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
blob - /dev/null
blob + 1c59b0cec269cd80342936e144bb26e6255135da (mode 644)
--- /dev/null
+++ ex4-16-6.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (display "Evaluating: ")
+ (newline)
+ (user-print exps)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.16. In this exercise we implement the method just described for interpreting internal definitions. We assume that the evaluator supports let (see exercise 4.6).
+
+;; a. Change lookup-variable-value (section 4.1.3) to signal an error if the value it finds is the symbol *unassigned*.
+
+;; see above
+
+;; b. Write a procedure scan-out-defines that takes a procedure body and returns an equivalent one that has no internal definitions, by making the transformation described above.
+
+;; (lambda <vars>
+;; (define u <e1>)
+;; (define v <e2>)
+;; <e3>)
+
+;; would be transformed into
+
+;; (lambda <vars>
+;; (let ((u '*unassigned*)
+;; (v '*unassigned*))
+;; (set! u <e1>)
+;; (set! v <e2>)
+;; <e3>))
+
+;; (newline)
+;; (display "test")
+;; (newline)
+
+
+(define (make-assignment var val)
+ (list 'set! var val))
+
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+
+;; ((let ((even? (quote *unassigned*))
+;; (odd? (quote *unassigned*)))
+;; (set! even?
+;; (lambda (n)
+
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; (even? x)))
+
+
+
+
+;; c. Install scan-out-defines in the interpreter, either in make-procedure or in procedure-body (see section 4.1.3). Which place is better? Why?
+
+;; better to put it in make-procedure. Otherwise, every time the procedure-body is requested for an application, we'd have to repeat the scanning. This would make applications quite slow and would be very inefficient.
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (define f-proc (eval 'f the-global-environment))
+;; (procedure-body f-proc)
+;; ((let ((even? (quote *unassigned*)) (odd? (quote *unassigned*))) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x)))
+;; (user-print (procedure-body f-proc))
+;; ((let ((even? (quote *unassigned*)) (odd? (quote *unassigned*))) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x)))
+;; (first-exp (procedure-body f-proc))
+;; (let? (first-exp (procedure-body f-proc)))
+
+;Value: #t
+
+;; 1 ]=> (let->combination (first-exp (procedure-body f-proc)))
+
+;Value 14: ((lambda (even? odd?) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x)) (quote *unassigned*) (quote *unassigned*))
+
+
+;Value 13: (let ((even? (quote *unassigned*)) (odd? (quote *unassigned*))) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x))
+
+;; (operator (let->combination (first-exp (procedure-body f-proc))))
+
+;Value 15: (lambda (even? odd?) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x))
+
+;; 1 ]=> (lambda-parameters (operator (let->combination (first-exp (procedure-body f-proc)))))
+
+;Value 16: (even? odd?)
+
+;; ((set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (even? x))
+
+;; there is an infinite loop going on
+;; the problem is that we scan out definitions and construct a let
+;; but, the let itself implies another lambda expression. To
+;; evaluate that lambda expression, we must construct another procedure.
+;; But then, we have to scan out *that* procedure. It never ends...
+
+;; (test-case
+;; (scan-out-defines
+;; '((define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; '(let ((even? '*unassigned*)
+;; (odd? '*unassigned*))
+;; (set! even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; (even? x)))
+
+;; ((let ((even? (quote *unassigned*))
+;; (odd? (quote *unassigned*)))
+;; (set! even?
+;; (lambda (n) (if (= n 0) true (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n) (if (= n 0) false (even? (- n 1)))))
+;; (even? x)))
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
blob - /dev/null
blob + e6977d237291c7b1d3668995abc76b869ef85125 (mode 644)
--- /dev/null
+++ ex4-16-7.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+
+
+
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
blob - /dev/null
blob + 43b41e8a804d9d9b6f1792a584c61651644df888 (mode 644)
--- /dev/null
+++ ex4-16-7.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.16. In this exercise we implement the method just described for interpreting internal definitions. We assume that the evaluator supports let (see exercise 4.6).
+
+;; a. Change lookup-variable-value (section 4.1.3) to signal an error if the value it finds is the symbol *unassigned*.
+
+;; see above
+
+;; b. Write a procedure scan-out-defines that takes a procedure body and returns an equivalent one that has no internal definitions, by making the transformation described above.
+
+;; (lambda <vars>
+;; (define u <e1>)
+;; (define v <e2>)
+;; <e3>)
+
+;; would be transformed into
+
+;; (lambda <vars>
+;; (let ((u '*unassigned*)
+;; (v '*unassigned*))
+;; (set! u <e1>)
+;; (set! v <e2>)
+;; <e3>))
+
+;; (newline)
+;; (display "test")
+;; (newline)
+
+
+(define (make-assignment var val)
+ (list 'set! var val))
+
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+
+;; ((let ((even? (quote *unassigned*))
+;; (odd? (quote *unassigned*)))
+;; (set! even?
+;; (lambda (n)
+
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; (even? x)))
+
+
+
+
+;; c. Install scan-out-defines in the interpreter, either in make-procedure or in procedure-body (see section 4.1.3). Which place is better? Why?
+
+;; better to put it in make-procedure. Otherwise, every time the procedure-body is requested for an application, we'd have to repeat the scanning. This would make applications quite slow and would be very inefficient.
+
+;; N.B.: make-unbound! is now broken because the defines are scanned out. The problem is that if there are internal defines, the frames of the defines have been moved around.
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
blob - /dev/null
blob + edfb780630746e47c8e2d31da2b6bceb43e8f082 (mode 644)
--- /dev/null
+++ ex4-16.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.16. In this exercise we implement the method just described for interpreting internal definitions. We assume that the evaluator supports let (see exercise 4.6).
+
+;; a. Change lookup-variable-value (section 4.1.3) to signal an error if the value it finds is the symbol *unassigned*.
+
+;; see above
+
+;; b. Write a procedure scan-out-defines that takes a procedure body and returns an equivalent one that has no internal definitions, by making the transformation described above.
+
+;; (lambda <vars>
+;; (define u <e1>)
+;; (define v <e2>)
+;; <e3>)
+
+;; would be transformed into
+
+;; (lambda <vars>
+;; (let ((u '*unassigned*)
+;; (v '*unassigned*))
+;; (set! u <e1>)
+;; (set! v <e2>)
+;; <e3>))
+
+;; (newline)
+;; (display "test")
+;; (newline)
+
+;; (define (make-assignment var val)
+;; (list 'set! var val))
+
+;; (define (scan-out-defines body)
+;; (define (scan-exps remaining-exps scanned-exps vars vals)
+;; (if (null? remaining-exps)
+;; (make-let vars
+;; (map (lambda (var)
+;; '*unassigned*)
+;; vars)
+;; (append
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars
+;; vals)
+;; scanned-exps))
+;; (let ((first (car remaining-exps))
+;; (rest (cdr remaining-exps)))
+;; (if (definition? first)
+;; (scan-exps rest
+;; scanned-exps
+;; (append vars (definition-variable first))
+;; (append vals (definition-value first)))
+;; (scan-exps rest
+;; (append scanned-exps first)
+;; vars
+;; vals)))))
+;; (scan-exps body '() '() '()))
+;; (filter definition? body)
+;; (remove definition? body)
+
+;; (define (make-let vars vals body)
+;; (cons 'let
+;; (cons (map list vars vals)
+;; body)))
+
+
+;; c. Install scan-out-defines in the interpreter, either in make-procedure or in procedure-body (see section 4.1.3). Which place is better? Why?
+
+;; better to put it in make-procedure. Otherwise, every time the procedure-body is requested for an application, we'd have to repeat the scanning. This would make applications quite slow and would be very inefficient.
+
+;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; (test-case
+;; (scan-out-defines
+;; '((define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; '(let ((even? '*unassigned*)
+;; (odd? '*unassigned*))
+;; (set! even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; (even? x)))
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
blob - /dev/null
blob + c25b180f4839c2d26b8457f6a3b9777821699eef (mode 644)
--- /dev/null
+++ ex4-16.scm~
+(define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+(define (unbound? exp)
+ (tagged-list? exp 'make-unbound!))
+(define (unbound-var exp)
+ (cadr exp))
+(define (eval-unbound exp env)
+ (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.15. Given a one-argument procedure p and an object a, p is said to ``halt'' on a if evaluating the expression (p a) returns a value (as opposed to terminating with an error message or running forever). Show that it is impossible to write a procedure halts? that correctly determines whether p halts on a for any procedure p and object a. Use the following reasoning: If you had such a procedure halts?, you could implement the following program:
+
+(define (run-forever) (run-forever))
+
+(define (try p)
+ (if (halts? p p)
+ (run-forever)
+ 'halted))
+
+;; Now consider evaluating the expression (try try) and show that any possible outcome (either halting or running forever) violates the intended behavior of halts?.23
+
+;; If (try try) halts, (halts? try try) will be true. But then, according to the definition of try above, (try try) will run forever.
+
+;; On the other hand, if (try try) does not halt, then (halts? try try) will be false. However, according to the definition of try above, this means that (try try) will return 'halted and therefore halt.
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+;; make-unbound!
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (make-unbound! x)
+ (* x x)))
+ 9)
+
+(test-eval
+ '(let ((x 3))
+ (let ((x 5))
+ (define y x)
+ (make-unbound! x)
+ (* y x)))
+ 15)
+
+(test-eval
+ '(let ((y -1) (x 3))
+ (let ((y 0.5) (x 5))
+ (define a x)
+ (define b y)
+ (make-unbound! x)
+ (make-unbound! y)
+ (* a b x y)))
+ (* 5 3 -1 0.5))
+
+(test-eval
+ '(let ((x 3) (y 4))
+ (let ((x 5))
+ (make-unbound! x)
+ (+ x 4)))
+ 7)
+
+(test-eval
+ '(let ((a 1) (b 2) (c 3) (d 4))
+ (make-unbound! b)
+ (+ a c d))
+ (+ 1 3 4))
+
+(test-eval
+ '(let ((x 4) (y 5))
+ (let ((a 1) (b 2) (c 3))
+ (let ((x (+ a b)) (y (+ c a)))
+ (make-unbound! x)
+ (let ((a x) (b (+ x y)))
+ (define z b)
+ (make-unbound! b)
+ (* (+ a z)
+ (+ a b y))))))
+ (* (+ 4 8)
+ (+ 4 2 4)))
blob - /dev/null
blob + 7eea8c8eca454ea9c8dff8912cca6aeee52a1d0d (mode 644)
--- /dev/null
+++ ex4-17.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.17. Draw diagrams of the environment in effect when evaluating the expression <e3> in the procedure in the text, comparing how this will be structured when definitions are interpreted sequentially with how it will be structured if definitions are scanned out as described. Why is there an extra frame in the transformed program? Explain why this difference in environment structure can never make a difference in the behavior of a correct program. Design a way to make the interpreter implement the ``simultaneous'' scope rule for internal definitions without constructing the extra frame.
+
+;; there is one extra frame due to the let because:
+
+;; (let ((<var1> <exp1>)
+;; (<var2> <exp2>)
+;; ...)
+;; <body>)
+
+;; is syntactic sugar for
+
+;; ((lambda (<var1> <var2> ...)
+;; <body>)
+;; <exp1> <exp2> ...)
+
+;; we could move all the internal definitions to the top by scanning them out and then moving them to the top
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
blob - /dev/null
blob + e6977d237291c7b1d3668995abc76b869ef85125 (mode 644)
--- /dev/null
+++ ex4-17.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+
+
+
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
blob - /dev/null
blob + a33095ba13a918caf594807c2d4c599d58cd0e07 (mode 644)
--- /dev/null
+++ ex4-18.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.18. Consider an alternative strategy for scanning out definitions that translates the example in the text to
+
+(lambda <vars>
+ (let ((u '*unassigned*)
+ (v '*unassigned*))
+ (let ((a <e1>)
+ (b <e2>))
+ (set! u a)
+ (set! v b))
+ <e3>))
+
+;; Here a and b are meant to represent new variable names, created by the interpreter, that do not appear in the user's program. Consider the solve procedure from section 3.5.4:
+
+(define (solve f y0 dt)
+ (define y (integral (delay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+;; Will this procedure work if internal definitions are scanned out as shown in this exercise? What if they are scanned out as shown in the text? Explain.
+
+;; No, because this enforces the rule that definition values cannot rely on other internal definitions. The new syntactic transformation would give us:
+
+(let ((y '*unassigned*)
+ (dy '*unassigned*))
+ (let ((u (integral (delay dy) y0 dt))
+ (v (stream-map f y)))
+ (set! y u)
+ (set! dy v)
+ y))
+
+;; however, it is impossible to evaluate the value for v in the second let because y is not yet defined (although it is possible to evaluate the value for u because of the delay special form)
+
+;; However, the procedure definition will work if we use the scan-out-defines as defined in the text.
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
blob - /dev/null
blob + 7eea8c8eca454ea9c8dff8912cca6aeee52a1d0d (mode 644)
--- /dev/null
+++ ex4-18.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.17. Draw diagrams of the environment in effect when evaluating the expression <e3> in the procedure in the text, comparing how this will be structured when definitions are interpreted sequentially with how it will be structured if definitions are scanned out as described. Why is there an extra frame in the transformed program? Explain why this difference in environment structure can never make a difference in the behavior of a correct program. Design a way to make the interpreter implement the ``simultaneous'' scope rule for internal definitions without constructing the extra frame.
+
+;; there is one extra frame due to the let because:
+
+;; (let ((<var1> <exp1>)
+;; (<var2> <exp2>)
+;; ...)
+;; <body>)
+
+;; is syntactic sugar for
+
+;; ((lambda (<var1> <var2> ...)
+;; <body>)
+;; <exp1> <exp2> ...)
+
+;; we could move all the internal definitions to the top by scanning them out and then moving them to the top
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
blob - /dev/null
blob + 32a644be4547911315fd0dfea7c8715826b5c0c0 (mode 644)
--- /dev/null
+++ ex4-19.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+
+;; Exercise 4.19. Ben Bitdiddle, Alyssa P. Hacker, and Eva Lu Ator are arguing about the desired result of evaluating the expression
+
+(let ((a 1))
+ (define (f x)
+ (define b (+ a x))
+ (define a 5)
+ (+ a b))
+ (f 10))
+
+;; Ben asserts that the result should be obtained using the sequential rule for define: b is defined to be 11, then a is defined to be 5, so the result is 16. Alyssa objects that mutual recursion requires the simultaneous scope rule for internal procedure definitions, and that it is unreasonable to treat procedure names differently from other names. Thus, she argues for the mechanism implemented in exercise 4.16. This would lead to a being unassigned at the time that the value for b is to be computed. Hence, in Alyssa's view the procedure should produce an error. Eva has a third opinion. She says that if the definitions of a and b are truly meant to be simultaneous, then the value 5 for a should be used in evaluating b. Hence, in Eva's view a should be 5, b should be 15, and the result should be 20. Which (if any) of these viewpoints do you support? Can you devise a way to implement internal definitions so that they behave as Eva prefers?26
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
blob - /dev/null
blob + a33095ba13a918caf594807c2d4c599d58cd0e07 (mode 644)
--- /dev/null
+++ ex4-19.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.18. Consider an alternative strategy for scanning out definitions that translates the example in the text to
+
+(lambda <vars>
+ (let ((u '*unassigned*)
+ (v '*unassigned*))
+ (let ((a <e1>)
+ (b <e2>))
+ (set! u a)
+ (set! v b))
+ <e3>))
+
+;; Here a and b are meant to represent new variable names, created by the interpreter, that do not appear in the user's program. Consider the solve procedure from section 3.5.4:
+
+(define (solve f y0 dt)
+ (define y (integral (delay dy) y0 dt))
+ (define dy (stream-map f y))
+ y)
+
+;; Will this procedure work if internal definitions are scanned out as shown in this exercise? What if they are scanned out as shown in the text? Explain.
+
+;; No, because this enforces the rule that definition values cannot rely on other internal definitions. The new syntactic transformation would give us:
+
+(let ((y '*unassigned*)
+ (dy '*unassigned*))
+ (let ((u (integral (delay dy) y0 dt))
+ (v (stream-map f y)))
+ (set! y u)
+ (set! dy v)
+ y))
+
+;; however, it is impossible to evaluate the value for v in the second let because y is not yet defined (although it is possible to evaluate the value for u because of the delay special form)
+
+;; However, the procedure definition will work if we use the scan-out-defines as defined in the text.
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
blob - /dev/null
blob + bdd9a435644a18371478609d8868db4ec57412a8 (mode 644)
--- /dev/null
+++ ex4-2.scm
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; Exercise 4.2. Louis Reasoner plans to reorder the cond clauses in eval so that the clause for procedure applications appears before the clause for assignments. He argues that this will make the interpreter more efficient: Since programs usually contain more applications than assignments, definitions, and so on, his modified eval will usually check fewer clauses than the original eval before identifying the type of an expression.
+
+;; a. What is wrong with Louis's plan? (Hint: What will Louis's evaluator do with the expression (define x 3)?)
+
+;; the define special form will be interpreted as an application because the only requirement is that the expression be a pair
+
+;; b. Louis is upset that his plan didn't work. He is willing to go to any lengths to make his evaluator recognize procedure applications before it checks for most other kinds of expressions. Help him by changing the syntax of the evaluated language so that procedure applications start with call. For example, instead of (factorial 3) we will now have to write (call factorial 3) and instead of (+ 1 2) we will have to write (call + 1 2).
+
+(define (application? exp) (tagged-list? exp 'call))
+(define (operator exp) (cadr exp))
+(define (operands exp) (cddr exp))
+(define (make-application op args)
+ (cons 'call (cons op args)))
+(geval
+ '(define (factorial n)
+ (if (call = n 0)
+ 1
+ (call * n (call factorial (call - n 1))))))
+(test-case (geval '(call factorial 5)) 120)
+
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (call + x y (call * x y))))
+ (+ 4 7 (* 4 7)))
blob - /dev/null
blob + b874d7777d006346a35fe4db686a2c0d7b56920d (mode 644)
--- /dev/null
+++ ex4-2.scm~
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (cons (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+
+;; Exercise 4.1. Notice that we cannot tell whether the metacircular evaluator evaluates operands from left to right or from right to left. Its evaluation order is inherited from the underlying Lisp: If the arguments to cons in list-of-values are evaluated from left to right, then list-of-values will evaluate operands from left to right; and if the arguments to cons are evaluated from right to left, then list-of-values will evaluate operands from right to left.
+
+;; Write a version of list-of-values that evaluates operands from left to right regardless of the order of evaluation in the underlying Lisp. Also write a version of list-of-values that evaluates operands from right to left.
+
+(define (list-of-values-l->r exps env)
+ (if (no-operands? exps)
+ '()
+ (let* ((first (eval (first-operand exps) env))
+ (rest (list-of-values (rest-operands exps) env)))
+ (cons first rest))))
+(define (list-of-values-r->l exps env)
+ (if (no-operands? exps)
+ '()
+ (let* ((rest (list-of-values (rest-operands exps) env))
+ (first (eval (first-operand exps) env)))
+ (cons first rest))))
+
+(geval
+ '(define old-value
+ (let ((x 0))
+ (lambda (y)
+ (let ((z x))
+ (set! x y)
+ z)))))
+
+(define list-of-values list-of-values-l->r)
+(test-case (geval '(+ (old-value 4) (old-value 5)))
+ 4)
+(test-case (geval '(- (old-value 2) (old-value 8)))
+ 3)
+(define list-of-values list-of-values-r->l)
+(test-case (geval '(+ (old-value 4) (old-value 5)))
+ 13)
+(test-case (geval '(- (old-value 2) (old-value 8)))
+ 4)
+
+
+;; eval test suite
+;; (test-case (geval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y))))
+;; (+ 4 7 (* 4 7)))
blob - /dev/null
blob + 2c6f9e190535eb98dcd980bda01359bb2708d579 (mode 644)
--- /dev/null
+++ ex4-20-2.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; Exercise 4.20. Because internal definitions look sequential but are actually simultaneous, some people prefer to avoid them entirely, and use the special form letrec instead. Letrec looks like let, so it is not surprising that the variables it binds are bound simultaneously and have the same scope as each other. The sample procedure f above can be written without internal definitions, but with exactly the same meaning, as
+
+;; (define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; <rest of body of f>))
+
+;; Letrec expressions, which have the form
+
+;; (letrec ((<var1> <exp1>) ... (<varn> <expn>))
+;; <body>)
+
+;; are a variation on let in which the expressions <expk> that provide the initial values for the variables <vark> are evaluated in an environment that includes all the letrec bindings. This permits recursion in the bindings, such as the mutual recursion of even? and odd? in the example above, or the evaluation of 10 factorial with
+
+;; (letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+
+
+;; a. Implement letrec as a derived expression, by transforming a letrec expression into a let expression as shown in the text above or in exercise 4.18. That is, the letrec variables should be created with a let and then be assigned their values with set!.
+
+;; the two definitions above can be transformed to the following
+
+;; (let ((fact '*unassigned*))
+;; (set! fact (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1))))))
+;; (fact 10))
+
+;; (define (f x)
+;; (let ((even? '*unassigned*)
+;; (odd? '*unassigned*))
+;; (set! even? (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd? (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; <rest of body of f>))
+
+
+;; b. Louis Reasoner is confused by all this fuss about internal definitions. The way he sees it, if you don't like to use define inside a procedure, you can just use let. Illustrate what is loose about his reasoning by drawing an environment diagram that shows the environment in which the <rest of body of f> is evaluated during evaluation of the expression (f 5), with f defined as in this exercise. Draw an environment diagram for the same evaluation, but with let in place of letrec in the definition of f.
+
+;; The problem with let is that you end up with:
+
+;; ((lambda (even? odd?)
+;; <rest of body of f>)
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+
+;; The two lambda expressions refer to symbols that are not defined. The two lambda expressions given as arguments will have the frame created by (f <arg>) as environments. However, in order for these expressions to be able to refer to even? and odd? in their procedure bodies, they need to be within the scope of the lambda in the operator.
+
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + f5e4f1ad89d6d5a3d7dac5ea3d99d879fc735e77 (mode 644)
--- /dev/null
+++ ex4-20-2.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; Exercise 4.20. Because internal definitions look sequential but are actually simultaneous, some people prefer to avoid them entirely, and use the special form letrec instead. Letrec looks like let, so it is not surprising that the variables it binds are bound simultaneously and have the same scope as each other. The sample procedure f above can be written without internal definitions, but with exactly the same meaning, as
+
+;; (define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; <rest of body of f>))
+
+;; Letrec expressions, which have the form
+
+;; (letrec ((<var1> <exp1>) ... (<varn> <expn>))
+;; <body>)
+
+;; are a variation on let in which the expressions <expk> that provide the initial values for the variables <vark> are evaluated in an environment that includes all the letrec bindings. This permits recursion in the bindings, such as the mutual recursion of even? and odd? in the example above, or the evaluation of 10 factorial with
+
+;; (letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+
+
+;; a. Implement letrec as a derived expression, by transforming a letrec expression into a let expression as shown in the text above or in exercise 4.18. That is, the letrec variables should be created with a let and then be assigned their values with set!.
+
+;; the two definitions above can be transformed to the following
+
+;; (let ((fact '*unassigned*))
+;; (set! fact (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1))))))
+;; (fact 10))
+
+;; (define (f x)
+;; (let ((even? '*unassigned*)
+;; (odd? '*unassigned*))
+;; (set! even? (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd? (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; <rest of body of f>))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+;; b. Louis Reasoner is confused by all this fuss about internal definitions. The way he sees it, if you don't like to use define inside a procedure, you can just use let. Illustrate what is loose about his reasoning by drawing an environment diagram that shows the environment in which the <rest of body of f> is evaluated during evaluation of the expression (f 5), with f defined as in this exercise. Draw an environment diagram for the same evaluation, but with let in place of letrec in the definition of f.
+
+
+
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + f5e4f1ad89d6d5a3d7dac5ea3d99d879fc735e77 (mode 644)
--- /dev/null
+++ ex4-20.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; Exercise 4.20. Because internal definitions look sequential but are actually simultaneous, some people prefer to avoid them entirely, and use the special form letrec instead. Letrec looks like let, so it is not surprising that the variables it binds are bound simultaneously and have the same scope as each other. The sample procedure f above can be written without internal definitions, but with exactly the same meaning, as
+
+;; (define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; <rest of body of f>))
+
+;; Letrec expressions, which have the form
+
+;; (letrec ((<var1> <exp1>) ... (<varn> <expn>))
+;; <body>)
+
+;; are a variation on let in which the expressions <expk> that provide the initial values for the variables <vark> are evaluated in an environment that includes all the letrec bindings. This permits recursion in the bindings, such as the mutual recursion of even? and odd? in the example above, or the evaluation of 10 factorial with
+
+;; (letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+
+
+;; a. Implement letrec as a derived expression, by transforming a letrec expression into a let expression as shown in the text above or in exercise 4.18. That is, the letrec variables should be created with a let and then be assigned their values with set!.
+
+;; the two definitions above can be transformed to the following
+
+;; (let ((fact '*unassigned*))
+;; (set! fact (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1))))))
+;; (fact 10))
+
+;; (define (f x)
+;; (let ((even? '*unassigned*)
+;; (odd? '*unassigned*))
+;; (set! even? (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (set! odd? (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1)))))
+;; <rest of body of f>))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+;; b. Louis Reasoner is confused by all this fuss about internal definitions. The way he sees it, if you don't like to use define inside a procedure, you can just use let. Illustrate what is loose about his reasoning by drawing an environment diagram that shows the environment in which the <rest of body of f> is evaluated during evaluation of the expression (f 5), with f defined as in this exercise. Draw an environment diagram for the same evaluation, but with let in place of letrec in the definition of f.
+
+
+
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + 32a644be4547911315fd0dfea7c8715826b5c0c0 (mode 644)
--- /dev/null
+++ ex4-20.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+
+;; Exercise 4.19. Ben Bitdiddle, Alyssa P. Hacker, and Eva Lu Ator are arguing about the desired result of evaluating the expression
+
+(let ((a 1))
+ (define (f x)
+ (define b (+ a x))
+ (define a 5)
+ (+ a b))
+ (f 10))
+
+;; Ben asserts that the result should be obtained using the sequential rule for define: b is defined to be 11, then a is defined to be 5, so the result is 16. Alyssa objects that mutual recursion requires the simultaneous scope rule for internal procedure definitions, and that it is unreasonable to treat procedure names differently from other names. Thus, she argues for the mechanism implemented in exercise 4.16. This would lead to a being unassigned at the time that the value for b is to be computed. Hence, in Alyssa's view the procedure should produce an error. Eva has a third opinion. She says that if the definitions of a and b are truly meant to be simultaneous, then the value 5 for a should be used in evaluating b. Hence, in Eva's view a should be 5, b should be 15, and the result should be 20. Which (if any) of these viewpoints do you support? Can you devise a way to implement internal definitions so that they behave as Eva prefers?26
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
blob - /dev/null
blob + 67dbca64427da3a4607cdf374457bb8bd423c817 (mode 644)
--- /dev/null
+++ ex4-21.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; Exercise 4.21. Amazingly, Louis's intuition in exercise 4.20 is correct. It is indeed possible to specify recursive procedures without using letrec (or even define), although the method for accomplishing this is much more subtle than Louis imagined. The following expression computes 10 factorial by applying a recursive factorial procedure:
+
+((lambda (n)
+ ((lambda (fact)
+ (fact fact n))
+ (lambda (ft k)
+ (if (= k 1)
+ 1
+ (* k (ft ft (- k 1)))))))
+ 10)
+
+;; a. Check (by evaluating the expression) that this really does compute factorials. Devise an analogous expression for computing Fibonacci numbers.
+
+
+;; ((lambda (n)
+;; ((lambda (fact)
+;; (fact fact n))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))))
+;; 10)
+
+;; ((lambda (fact)
+;; (fact fact 10))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1))))))
+
+;; ((lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; 10)
+
+;; (if (= 10 1)
+;; 1
+;; (* 10 ((lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (- 10 1))))
+
+;; (* 10 ((lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; 9))
+
+;; (* 10
+;; (if (= 9 1)
+;; 1
+;; (* 9 ((lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (- 9 1)))))
+
+;; (* 10
+;; (* 9 ((lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; 8)))
+
+;; and so forth
+
+(test-case
+ ((lambda (n)
+ ((lambda (fib)
+ (fib fib n))
+ (lambda (ft k)
+ (if (<= k 1)
+ k
+ (+ (ft ft (- k 1)) (ft ft (- k 2)))))))
+ 10)
+ 55)
+
+
+;; b. Consider the following procedure, which includes mutually recursive internal definitions:
+
+;; (define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x))
+
+;; Fill in the missing expressions to complete an alternative definition of f, which uses neither internal definitions nor letrec:
+
+(define (f x)
+ ((lambda (even? odd?)
+ (even? even? odd? x))
+ (lambda (ev? od? n)
+ (if (= n 0) true (od? ev? od? (- n 1))))
+ (lambda (ev? od? n)
+ (if (= n 0) false (ev? ev? od? (- n 1))))))
+
+(test-case (f 0) true)
+(test-case (f 2) true)
+(test-case (f 4) true)
+(test-case (f 6) true)
+(test-case (f 8) true)
+(test-case (f 1) false)
+(test-case (f 3) false)
+(test-case (f 5) false)
+(test-case (f 7) false)
+(test-case (f 9) false)
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
blob - /dev/null
blob + 8da5b7212ef81129abe12c6d99d1ec0011db0727 (mode 644)
--- /dev/null
+++ ex4-21.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; Exercise 4.21. Amazingly, Louis's intuition in exercise 4.20 is correct. It is indeed possible to specify recursive procedures without using letrec (or even define), although the method for accomplishing this is much more subtle than Louis imagined. The following expression computes 10 factorial by applying a recursive factorial procedure:
+
+((lambda (n)
+ ((lambda (fact)
+ (fact fact n))
+ (lambda (ft k)
+ (if (= k 1)
+ 1
+ (* k (ft ft (- k 1)))))))
+ 10)
+
+;; a. Check (by evaluating the expression) that this really does compute factorials. Devise an analogous expression for computing Fibonacci numbers.
+
+
+;; ((lambda (n)
+;; ((lambda (fact)
+;; (fact fact n))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))))
+;; 10)
+
+;; ((lambda (fact)
+;; (fact fact 10))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1))))))
+
+;; ((lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; 10)
+
+;; (if (= 10 1)
+;; 1
+;; (* 10 ((lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (- 10 1))))
+
+;; (* 10 ((lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; 9))
+
+;; (* 10
+;; (if (= 9 1)
+;; 1
+;; (* 9 ((lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (- 9 1)))))
+
+;; (* 10
+;; (* 9 ((lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; (lambda (ft k)
+;; (if (= k 1)
+;; 1
+;; (* k (ft ft (- k 1)))))
+;; 8)))
+
+;; and so forth
+
+(test-case
+ ((lambda (n)
+ ((lambda (fib)
+ (fib fib n))
+ (lambda (ft k)
+ (if (<= k 1)
+ k
+ (+ (ft ft (- k 1)) (ft ft (- k 2)))))))
+ 10)
+ 55)
+
+
+;; b. Consider the following procedure, which includes mutually recursive internal definitions:
+
+;; (define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x))
+
+;; Fill in the missing expressions to complete an alternative definition of f, which uses neither internal definitions nor letrec:
+
+(define (f x)
+ ((lambda (even? odd?)
+ (even? even? odd? x))
+ (lambda (ev? od? n)
+ (if (= n 0) true (od? ev? od? (- n 1))))
+ (lambda (ev? od? n)
+ (if (= n 0) false (ev? ev? od? (- n 1))))))
+
+(test-case (f 0) true)
+(test-case (f 2) true)
+(test-case (f 4) true)
+(test-case (f 6) true)
+(test-case (f 8) true)
+(test-case (f 1) false)
+(test-case (f 3) false)
+(test-case (f 5) false)
+(test-case (f 7) false)
+(test-case (f 9) false)
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + aea3550a914413175b6fe53e75e6dc7dbf8e71ae (mode 644)
--- /dev/null
+++ ex4-22-2.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ ((analyze exp) env))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+(define (analyze-self-evaluating exp)
+ (lambda (env) exp))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env) qval)))
+(define (analyze-variable exp)
+ (lambda (env) (lookup-variable-value exp env)))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env)
+ (set-variable-value! var (vproc env) env)
+ 'ok)))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env)
+ (define-variable! var (vproc env) env)
+ 'ok)))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env)
+ (if (true? (pproc env))
+ (cproc env)
+ (aproc env)))))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env) (make-procedure vars bproc env))))
+(define (analyze-sequence exps)
+ (define (sequentially proc1 proc2)
+ (lambda (env) (proc1 env) (proc2 env)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env)
+ (execute-application (fproc env)
+ (map (lambda (aproc) (aproc env))
+ aprocs)))))
+(define (execute-application proc args)
+ (cond ((primitive-procedure? proc)
+ (apply-primitive-procedure proc args))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; (define (eval exp env)
+;; (cond ((self-evaluating? exp) exp)
+;; ((variable? exp) (lookup-variable-value exp env))
+;; ((quoted? exp) (text-of-quotation exp))
+;; ((assignment? exp) (eval-assignment exp env))
+;; ((definition? exp) (eval-definition exp env))
+;; ;; ((unbound? exp) (eval-unbound exp env))
+;; ((if? exp) (eval-if exp env))
+;; ((and? exp) (eval-and exp env))
+;; ((or? exp) (eval-or exp env))
+;; ((lambda? exp)
+;; (make-procedure (lambda-parameters exp)
+;; (lambda-body exp)
+;; env))
+;; ((begin? exp)
+;; (eval-sequence (begin-actions exp) env))
+;; ((cond? exp) (eval (cond->if exp) env))
+;; ((let? exp) (eval (let->combination exp) env))
+;; ((let*? exp) (eval (let*->nested-lets exp) env))
+;; ((named-let? exp) (eval (named-let->combination exp) env))
+;; ((letrec? exp) (eval (letrec->let exp) env))
+;; ((do? exp) (eval (do->combination exp) env))
+;; ((application? exp)
+;; (apply (eval (operator exp) env)
+;; (list-of-values (operands exp) env)))
+;; (else
+;; (error "Unknown expression type -- EVAL" exp))))
+;; (define (apply procedure arguments)
+;; (cond ((primitive-procedure? procedure)
+;; (apply-primitive-procedure procedure arguments))
+;; ((compound-procedure? procedure)
+;; (eval-sequence
+;; (procedure-body procedure)
+;; (extend-environment
+;; (procedure-parameters procedure)
+;; arguments
+;; (procedure-environment procedure))))
+;; (else
+;; (error
+;; "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; Exercise 4.22. Extend the evaluator in this section to support the special form let. (See exercise 4.6.)
+
+;; see above
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + f5223c5d35b4a9acbe763078ace44f656fbccf2d (mode 644)
--- /dev/null
+++ ex4-22-2.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ ((analyze exp) env))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((lambda? exp) (analyze-lambda exp))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+(define (analyze-self-evaluating exp)
+ (lambda (env) exp))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env) qval)))
+(define (analyze-variable exp)
+ (lambda (env) (lookup-variable-value exp env)))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env)
+ (set-variable-value! var (vproc env) env)
+ 'ok)))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env)
+ (define-variable! var (vproc env) env)
+ 'ok)))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env)
+ (if (true? (pproc env))
+ (cproc env)
+ (aproc env)))))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env) (make-procedure vars bproc env))))
+(define (analyze-sequence exps)
+ (define (sequentially proc1 proc2)
+ (lambda (env) (proc1 env) (proc2 env)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env)
+ (execute-application (fproc env)
+ (map (lambda (aproc) (aproc env))
+ aprocs)))))
+(define (execute-application proc args)
+ (cond ((primitive-procedure? proc)
+ (apply-primitive-procedure proc args))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; (define (eval exp env)
+;; (cond ((self-evaluating? exp) exp)
+;; ((variable? exp) (lookup-variable-value exp env))
+;; ((quoted? exp) (text-of-quotation exp))
+;; ((assignment? exp) (eval-assignment exp env))
+;; ((definition? exp) (eval-definition exp env))
+;; ;; ((unbound? exp) (eval-unbound exp env))
+;; ((if? exp) (eval-if exp env))
+;; ((and? exp) (eval-and exp env))
+;; ((or? exp) (eval-or exp env))
+;; ((lambda? exp)
+;; (make-procedure (lambda-parameters exp)
+;; (lambda-body exp)
+;; env))
+;; ((begin? exp)
+;; (eval-sequence (begin-actions exp) env))
+;; ((cond? exp) (eval (cond->if exp) env))
+;; ((let? exp) (eval (let->combination exp) env))
+;; ((let*? exp) (eval (let*->nested-lets exp) env))
+;; ((named-let? exp) (eval (named-let->combination exp) env))
+;; ((letrec? exp) (eval (letrec->let exp) env))
+;; ((do? exp) (eval (do->combination exp) env))
+;; ((application? exp)
+;; (apply (eval (operator exp) env)
+;; (list-of-values (operands exp) env)))
+;; (else
+;; (error "Unknown expression type -- EVAL" exp))))
+;; (define (apply procedure arguments)
+;; (cond ((primitive-procedure? procedure)
+;; (apply-primitive-procedure procedure arguments))
+;; ((compound-procedure? procedure)
+;; (eval-sequence
+;; (procedure-body procedure)
+;; (extend-environment
+;; (procedure-parameters procedure)
+;; arguments
+;; (procedure-environment procedure))))
+;; (else
+;; (error
+;; "Unknown procedure type -- APPLY" procedure))))
+
+;; (define (list-of-values exps env)
+;; (if (no-operands? exps)
+;; '()
+;; (cons (eval (first-operand exps) env)
+;; (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + f5223c5d35b4a9acbe763078ace44f656fbccf2d (mode 644)
--- /dev/null
+++ ex4-22.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ ((analyze exp) env))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((lambda? exp) (analyze-lambda exp))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+(define (analyze-self-evaluating exp)
+ (lambda (env) exp))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env) qval)))
+(define (analyze-variable exp)
+ (lambda (env) (lookup-variable-value exp env)))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env)
+ (set-variable-value! var (vproc env) env)
+ 'ok)))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env)
+ (define-variable! var (vproc env) env)
+ 'ok)))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env)
+ (if (true? (pproc env))
+ (cproc env)
+ (aproc env)))))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env) (make-procedure vars bproc env))))
+(define (analyze-sequence exps)
+ (define (sequentially proc1 proc2)
+ (lambda (env) (proc1 env) (proc2 env)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env)
+ (execute-application (fproc env)
+ (map (lambda (aproc) (aproc env))
+ aprocs)))))
+(define (execute-application proc args)
+ (cond ((primitive-procedure? proc)
+ (apply-primitive-procedure proc args))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; (define (eval exp env)
+;; (cond ((self-evaluating? exp) exp)
+;; ((variable? exp) (lookup-variable-value exp env))
+;; ((quoted? exp) (text-of-quotation exp))
+;; ((assignment? exp) (eval-assignment exp env))
+;; ((definition? exp) (eval-definition exp env))
+;; ;; ((unbound? exp) (eval-unbound exp env))
+;; ((if? exp) (eval-if exp env))
+;; ((and? exp) (eval-and exp env))
+;; ((or? exp) (eval-or exp env))
+;; ((lambda? exp)
+;; (make-procedure (lambda-parameters exp)
+;; (lambda-body exp)
+;; env))
+;; ((begin? exp)
+;; (eval-sequence (begin-actions exp) env))
+;; ((cond? exp) (eval (cond->if exp) env))
+;; ((let? exp) (eval (let->combination exp) env))
+;; ((let*? exp) (eval (let*->nested-lets exp) env))
+;; ((named-let? exp) (eval (named-let->combination exp) env))
+;; ((letrec? exp) (eval (letrec->let exp) env))
+;; ((do? exp) (eval (do->combination exp) env))
+;; ((application? exp)
+;; (apply (eval (operator exp) env)
+;; (list-of-values (operands exp) env)))
+;; (else
+;; (error "Unknown expression type -- EVAL" exp))))
+;; (define (apply procedure arguments)
+;; (cond ((primitive-procedure? procedure)
+;; (apply-primitive-procedure procedure arguments))
+;; ((compound-procedure? procedure)
+;; (eval-sequence
+;; (procedure-body procedure)
+;; (extend-environment
+;; (procedure-parameters procedure)
+;; arguments
+;; (procedure-environment procedure))))
+;; (else
+;; (error
+;; "Unknown procedure type -- APPLY" procedure))))
+
+;; (define (list-of-values exps env)
+;; (if (no-operands? exps)
+;; '()
+;; (cons (eval (first-operand exps) env)
+;; (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + e33f6a83fd4af800c89663e5a44c1155347dc755 (mode 644)
--- /dev/null
+++ ex4-22.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ ((analyze exp) env))
+
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + 2c774f3b32ea1554105506ce8baf5903b6631565 (mode 644)
--- /dev/null
+++ ex4-23.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ ((analyze exp) env))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+(define (analyze-self-evaluating exp)
+ (lambda (env) exp))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env) qval)))
+(define (analyze-variable exp)
+ (lambda (env) (lookup-variable-value exp env)))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env)
+ (set-variable-value! var (vproc env) env)
+ 'ok)))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env)
+ (define-variable! var (vproc env) env)
+ 'ok)))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env)
+ (if (true? (pproc env))
+ (cproc env)
+ (aproc env)))))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env) (make-procedure vars bproc env))))
+(define (analyze-sequence exps)
+ (define (sequentially proc1 proc2)
+ (lambda (env) (proc1 env) (proc2 env)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env)
+ (execute-application (fproc env)
+ (map (lambda (aproc) (aproc env))
+ aprocs)))))
+(define (execute-application proc args)
+ (cond ((primitive-procedure? proc)
+ (apply-primitive-procedure proc args))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; (define (eval exp env)
+;; (cond ((self-evaluating? exp) exp)
+;; ((variable? exp) (lookup-variable-value exp env))
+;; ((quoted? exp) (text-of-quotation exp))
+;; ((assignment? exp) (eval-assignment exp env))
+;; ((definition? exp) (eval-definition exp env))
+;; ;; ((unbound? exp) (eval-unbound exp env))
+;; ((if? exp) (eval-if exp env))
+;; ((and? exp) (eval-and exp env))
+;; ((or? exp) (eval-or exp env))
+;; ((lambda? exp)
+;; (make-procedure (lambda-parameters exp)
+;; (lambda-body exp)
+;; env))
+;; ((begin? exp)
+;; (eval-sequence (begin-actions exp) env))
+;; ((cond? exp) (eval (cond->if exp) env))
+;; ((let? exp) (eval (let->combination exp) env))
+;; ((let*? exp) (eval (let*->nested-lets exp) env))
+;; ((named-let? exp) (eval (named-let->combination exp) env))
+;; ((letrec? exp) (eval (letrec->let exp) env))
+;; ((do? exp) (eval (do->combination exp) env))
+;; ((application? exp)
+;; (apply (eval (operator exp) env)
+;; (list-of-values (operands exp) env)))
+;; (else
+;; (error "Unknown expression type -- EVAL" exp))))
+;; (define (apply procedure arguments)
+;; (cond ((primitive-procedure? procedure)
+;; (apply-primitive-procedure procedure arguments))
+;; ((compound-procedure? procedure)
+;; (eval-sequence
+;; (procedure-body procedure)
+;; (extend-environment
+;; (procedure-parameters procedure)
+;; arguments
+;; (procedure-environment procedure))))
+;; (else
+;; (error
+;; "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.23. Alyssa P. Hacker doesn't understand why analyze-sequence needs to be so complicated. All the other analysis procedures are straightforward transformations of the corresponding evaluation procedures (or eval clauses) in section 4.1.1. She expected analyze-sequence to look like this:
+
+(define (analyze-sequence exps)
+ (define (execute-sequence procs env)
+ (cond ((null? (cdr procs)) ((car procs) env))
+ (else ((car procs) env)
+ (execute-sequence (cdr procs) env))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (lambda (env) (execute-sequence procs env))))
+
+;; Eva Lu Ator explains to Alyssa that the version in the text does more of the work of evaluating a sequence at analysis time. Alyssa's sequence-execution procedure, rather than having the calls to the individual execution procedures built in, loops through the procedures in order to call them: In effect, although the individual expressions in the sequence have been analyzed, the sequence itself has not been.
+
+;; Compare the two versions of analyze-sequence. For example, consider the common case (typical of procedure bodies) where the sequence has just one expression. What work will the execution procedure produced by Alyssa's program do? What about the execution procedure produced by the program in the text above? How do the two versions compare for a sequence with two expressions?
+
+;; In Alyssa's code, looping through the sequences takes place at evaluating, not during analysis
+
+;; in the code in the text, there is no looping as the applications are built right into the lambda expression:
+
+(lambda (env)
+ ((lambda (env)
+ ((lambda (env)
+ (<proc1> env)
+ (<proc2> env)) env)
+ (<proc3> env))
+ env)
+ (<proc4> env))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + f5223c5d35b4a9acbe763078ace44f656fbccf2d (mode 644)
--- /dev/null
+++ ex4-23.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ ((analyze exp) env))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((lambda? exp) (analyze-lambda exp))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+(define (analyze-self-evaluating exp)
+ (lambda (env) exp))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env) qval)))
+(define (analyze-variable exp)
+ (lambda (env) (lookup-variable-value exp env)))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env)
+ (set-variable-value! var (vproc env) env)
+ 'ok)))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env)
+ (define-variable! var (vproc env) env)
+ 'ok)))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env)
+ (if (true? (pproc env))
+ (cproc env)
+ (aproc env)))))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env) (make-procedure vars bproc env))))
+(define (analyze-sequence exps)
+ (define (sequentially proc1 proc2)
+ (lambda (env) (proc1 env) (proc2 env)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env)
+ (execute-application (fproc env)
+ (map (lambda (aproc) (aproc env))
+ aprocs)))))
+(define (execute-application proc args)
+ (cond ((primitive-procedure? proc)
+ (apply-primitive-procedure proc args))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; (define (eval exp env)
+;; (cond ((self-evaluating? exp) exp)
+;; ((variable? exp) (lookup-variable-value exp env))
+;; ((quoted? exp) (text-of-quotation exp))
+;; ((assignment? exp) (eval-assignment exp env))
+;; ((definition? exp) (eval-definition exp env))
+;; ;; ((unbound? exp) (eval-unbound exp env))
+;; ((if? exp) (eval-if exp env))
+;; ((and? exp) (eval-and exp env))
+;; ((or? exp) (eval-or exp env))
+;; ((lambda? exp)
+;; (make-procedure (lambda-parameters exp)
+;; (lambda-body exp)
+;; env))
+;; ((begin? exp)
+;; (eval-sequence (begin-actions exp) env))
+;; ((cond? exp) (eval (cond->if exp) env))
+;; ((let? exp) (eval (let->combination exp) env))
+;; ((let*? exp) (eval (let*->nested-lets exp) env))
+;; ((named-let? exp) (eval (named-let->combination exp) env))
+;; ((letrec? exp) (eval (letrec->let exp) env))
+;; ((do? exp) (eval (do->combination exp) env))
+;; ((application? exp)
+;; (apply (eval (operator exp) env)
+;; (list-of-values (operands exp) env)))
+;; (else
+;; (error "Unknown expression type -- EVAL" exp))))
+;; (define (apply procedure arguments)
+;; (cond ((primitive-procedure? procedure)
+;; (apply-primitive-procedure procedure arguments))
+;; ((compound-procedure? procedure)
+;; (eval-sequence
+;; (procedure-body procedure)
+;; (extend-environment
+;; (procedure-parameters procedure)
+;; arguments
+;; (procedure-environment procedure))))
+;; (else
+;; (error
+;; "Unknown procedure type -- APPLY" procedure))))
+
+;; (define (list-of-values exps env)
+;; (if (no-operands? exps)
+;; '()
+;; (cons (eval (first-operand exps) env)
+;; (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters (scan-out-defines body) env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + 8b925e8d098c65d09eab0f6820c3f93fa6bf3b26 (mode 644)
--- /dev/null
+++ ex4-24.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ ((analyze exp) env))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+(define (analyze-self-evaluating exp)
+ (lambda (env) exp))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env) qval)))
+(define (analyze-variable exp)
+ (lambda (env) (lookup-variable-value exp env)))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env)
+ (set-variable-value! var (vproc env) env)
+ 'ok)))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env)
+ (define-variable! var (vproc env) env)
+ 'ok)))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env)
+ (if (true? (pproc env))
+ (cproc env)
+ (aproc env)))))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env) (make-procedure vars bproc env))))
+(define (analyze-sequence exps)
+ (define (sequentially proc1 proc2)
+ (lambda (env) (proc1 env) (proc2 env)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env)
+ (execute-application (fproc env)
+ (map (lambda (aproc) (aproc env))
+ aprocs)))))
+(define (execute-application proc args)
+ (cond ((primitive-procedure? proc)
+ (apply-primitive-procedure proc args))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; (define (eval exp env)
+;; (cond ((self-evaluating? exp) exp)
+;; ((variable? exp) (lookup-variable-value exp env))
+;; ((quoted? exp) (text-of-quotation exp))
+;; ((assignment? exp) (eval-assignment exp env))
+;; ((definition? exp) (eval-definition exp env))
+;; ;; ((unbound? exp) (eval-unbound exp env))
+;; ((if? exp) (eval-if exp env))
+;; ((and? exp) (eval-and exp env))
+;; ((or? exp) (eval-or exp env))
+;; ((lambda? exp)
+;; (make-procedure (lambda-parameters exp)
+;; (lambda-body exp)
+;; env))
+;; ((begin? exp)
+;; (eval-sequence (begin-actions exp) env))
+;; ((cond? exp) (eval (cond->if exp) env))
+;; ((let? exp) (eval (let->combination exp) env))
+;; ((let*? exp) (eval (let*->nested-lets exp) env))
+;; ((named-let? exp) (eval (named-let->combination exp) env))
+;; ((letrec? exp) (eval (letrec->let exp) env))
+;; ((do? exp) (eval (do->combination exp) env))
+;; ((application? exp)
+;; (apply (eval (operator exp) env)
+;; (list-of-values (operands exp) env)))
+;; (else
+;; (error "Unknown expression type -- EVAL" exp))))
+;; (define (apply procedure arguments)
+;; (cond ((primitive-procedure? procedure)
+;; (apply-primitive-procedure procedure arguments))
+;; ((compound-procedure? procedure)
+;; (eval-sequence
+;; (procedure-body procedure)
+;; (extend-environment
+;; (procedure-parameters procedure)
+;; arguments
+;; (procedure-environment procedure))))
+;; (else
+;; (error
+;; "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + 2c774f3b32ea1554105506ce8baf5903b6631565 (mode 644)
--- /dev/null
+++ ex4-24.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ ((analyze exp) env))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+(define (analyze-self-evaluating exp)
+ (lambda (env) exp))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env) qval)))
+(define (analyze-variable exp)
+ (lambda (env) (lookup-variable-value exp env)))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env)
+ (set-variable-value! var (vproc env) env)
+ 'ok)))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env)
+ (define-variable! var (vproc env) env)
+ 'ok)))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env)
+ (if (true? (pproc env))
+ (cproc env)
+ (aproc env)))))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env) (make-procedure vars bproc env))))
+(define (analyze-sequence exps)
+ (define (sequentially proc1 proc2)
+ (lambda (env) (proc1 env) (proc2 env)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env)
+ (execute-application (fproc env)
+ (map (lambda (aproc) (aproc env))
+ aprocs)))))
+(define (execute-application proc args)
+ (cond ((primitive-procedure? proc)
+ (apply-primitive-procedure proc args))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; (define (eval exp env)
+;; (cond ((self-evaluating? exp) exp)
+;; ((variable? exp) (lookup-variable-value exp env))
+;; ((quoted? exp) (text-of-quotation exp))
+;; ((assignment? exp) (eval-assignment exp env))
+;; ((definition? exp) (eval-definition exp env))
+;; ;; ((unbound? exp) (eval-unbound exp env))
+;; ((if? exp) (eval-if exp env))
+;; ((and? exp) (eval-and exp env))
+;; ((or? exp) (eval-or exp env))
+;; ((lambda? exp)
+;; (make-procedure (lambda-parameters exp)
+;; (lambda-body exp)
+;; env))
+;; ((begin? exp)
+;; (eval-sequence (begin-actions exp) env))
+;; ((cond? exp) (eval (cond->if exp) env))
+;; ((let? exp) (eval (let->combination exp) env))
+;; ((let*? exp) (eval (let*->nested-lets exp) env))
+;; ((named-let? exp) (eval (named-let->combination exp) env))
+;; ((letrec? exp) (eval (letrec->let exp) env))
+;; ((do? exp) (eval (do->combination exp) env))
+;; ((application? exp)
+;; (apply (eval (operator exp) env)
+;; (list-of-values (operands exp) env)))
+;; (else
+;; (error "Unknown expression type -- EVAL" exp))))
+;; (define (apply procedure arguments)
+;; (cond ((primitive-procedure? procedure)
+;; (apply-primitive-procedure procedure arguments))
+;; ((compound-procedure? procedure)
+;; (eval-sequence
+;; (procedure-body procedure)
+;; (extend-environment
+;; (procedure-parameters procedure)
+;; arguments
+;; (procedure-environment procedure))))
+;; (else
+;; (error
+;; "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.23. Alyssa P. Hacker doesn't understand why analyze-sequence needs to be so complicated. All the other analysis procedures are straightforward transformations of the corresponding evaluation procedures (or eval clauses) in section 4.1.1. She expected analyze-sequence to look like this:
+
+(define (analyze-sequence exps)
+ (define (execute-sequence procs env)
+ (cond ((null? (cdr procs)) ((car procs) env))
+ (else ((car procs) env)
+ (execute-sequence (cdr procs) env))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (lambda (env) (execute-sequence procs env))))
+
+;; Eva Lu Ator explains to Alyssa that the version in the text does more of the work of evaluating a sequence at analysis time. Alyssa's sequence-execution procedure, rather than having the calls to the individual execution procedures built in, loops through the procedures in order to call them: In effect, although the individual expressions in the sequence have been analyzed, the sequence itself has not been.
+
+;; Compare the two versions of analyze-sequence. For example, consider the common case (typical of procedure bodies) where the sequence has just one expression. What work will the execution procedure produced by Alyssa's program do? What about the execution procedure produced by the program in the text above? How do the two versions compare for a sequence with two expressions?
+
+;; In Alyssa's code, looping through the sequences takes place at evaluating, not during analysis
+
+;; in the code in the text, there is no looping as the applications are built right into the lambda expression:
+
+(lambda (env)
+ ((lambda (env)
+ ((lambda (env)
+ (<proc1> env)
+ (<proc2> env)) env)
+ (<proc3> env))
+ env)
+ (<proc4> env))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + c3466e920be6667d3f7250cbdf0c2734649cb333 (mode 644)
--- /dev/null
+++ ex4-25-2.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + de11493c369c2de1263ced14d1afebe55f3bc6dc (mode 644)
--- /dev/null
+++ ex4-25-2.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+v (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + de11493c369c2de1263ced14d1afebe55f3bc6dc (mode 644)
--- /dev/null
+++ ex4-25.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+v (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + 8b925e8d098c65d09eab0f6820c3f93fa6bf3b26 (mode 644)
--- /dev/null
+++ ex4-25.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ ((analyze exp) env))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+(define (analyze-self-evaluating exp)
+ (lambda (env) exp))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env) qval)))
+(define (analyze-variable exp)
+ (lambda (env) (lookup-variable-value exp env)))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env)
+ (set-variable-value! var (vproc env) env)
+ 'ok)))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env)
+ (define-variable! var (vproc env) env)
+ 'ok)))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env)
+ (if (true? (pproc env))
+ (cproc env)
+ (aproc env)))))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env) (make-procedure vars bproc env))))
+(define (analyze-sequence exps)
+ (define (sequentially proc1 proc2)
+ (lambda (env) (proc1 env) (proc2 env)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env)
+ (execute-application (fproc env)
+ (map (lambda (aproc) (aproc env))
+ aprocs)))))
+(define (execute-application proc args)
+ (cond ((primitive-procedure? proc)
+ (apply-primitive-procedure proc args))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; (define (eval exp env)
+;; (cond ((self-evaluating? exp) exp)
+;; ((variable? exp) (lookup-variable-value exp env))
+;; ((quoted? exp) (text-of-quotation exp))
+;; ((assignment? exp) (eval-assignment exp env))
+;; ((definition? exp) (eval-definition exp env))
+;; ;; ((unbound? exp) (eval-unbound exp env))
+;; ((if? exp) (eval-if exp env))
+;; ((and? exp) (eval-and exp env))
+;; ((or? exp) (eval-or exp env))
+;; ((lambda? exp)
+;; (make-procedure (lambda-parameters exp)
+;; (lambda-body exp)
+;; env))
+;; ((begin? exp)
+;; (eval-sequence (begin-actions exp) env))
+;; ((cond? exp) (eval (cond->if exp) env))
+;; ((let? exp) (eval (let->combination exp) env))
+;; ((let*? exp) (eval (let*->nested-lets exp) env))
+;; ((named-let? exp) (eval (named-let->combination exp) env))
+;; ((letrec? exp) (eval (letrec->let exp) env))
+;; ((do? exp) (eval (do->combination exp) env))
+;; ((application? exp)
+;; (apply (eval (operator exp) env)
+;; (list-of-values (operands exp) env)))
+;; (else
+;; (error "Unknown expression type -- EVAL" exp))))
+;; (define (apply procedure arguments)
+;; (cond ((primitive-procedure? procedure)
+;; (apply-primitive-procedure procedure arguments))
+;; ((compound-procedure? procedure)
+;; (eval-sequence
+;; (procedure-body procedure)
+;; (extend-environment
+;; (procedure-parameters procedure)
+;; arguments
+;; (procedure-environment procedure))))
+;; (else
+;; (error
+;; "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + 4069bed9f75c378d333ab5d0f298075acbee1106 (mode 644)
--- /dev/null
+++ ex4-27.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+;; Give the missing values in the following sequence of interactions, and explain your answers.38
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + bfeccb00013904b46c7d1b736a9da157bac4fd80 (mode 644)
--- /dev/null
+++ ex4-27.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-values arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + c6a0c1ca32b82a44763367bddfdd6ce25f659402 (mode 644)
--- /dev/null
+++ ex4-28.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; Exercise 4.28. Eval uses actual-value rather than eval to evaluate the operator before passing it to apply, in order to force the value of the operator. Give an example that demonstrates the need for this forcing.
+
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+
+;; should be 2 but will give an error because f is bound to a thunk
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
blob - /dev/null
blob + 4069bed9f75c378d333ab5d0f298075acbee1106 (mode 644)
--- /dev/null
+++ ex4-28.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+;; Give the missing values in the following sequence of interactions, and explain your answers.38
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
blob - /dev/null
blob + 2bb0b2862e13aaca05e9117ebb6c0839c453ec68 (mode 644)
--- /dev/null
+++ ex4-29.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; Exercise 4.29. Exhibit a program that you would expect to run much more slowly without memoization than with memoization. Also, consider the following interaction, where the id procedure is defined as in exercise 4.27 and count starts at 0:
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+;; Give the responses both when the evaluator memoizes and when it does not.
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
blob - /dev/null
blob + c6a0c1ca32b82a44763367bddfdd6ce25f659402 (mode 644)
--- /dev/null
+++ ex4-29.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; Exercise 4.28. Eval uses actual-value rather than eval to evaluate the operator before passing it to apply, in order to force the value of the operator. Give an example that demonstrates the need for this forcing.
+
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+
+;; should be 2 but will give an error because f is bound to a thunk
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
blob - /dev/null
blob + 5682ce15867bc4883ab31e29b81ec47ad97ad5dc (mode 644)
--- /dev/null
+++ ex4-3.scm
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+
+(define (make-table)
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; Exercise 4.3. Rewrite eval so that the dispatch is done in data-directed style. Compare this with the data-directed differentiation procedure of exercise 2.73. (You may use the car of a compound expression as the type of the expression, as is appropriate for the syntax implemented in this section.
+
+(define (form? exp)
+ (pair? exp))
+(define (form-type exp)
+ (car exp))
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((and (form? exp)
+ (get (form-type exp) 'eval))
+ ((get (form-type exp) 'eval) exp env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp env) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(put 'quote 'eval text-of-quotation)
+(put 'set! 'eval eval-assignment)
+(put 'define 'eval eval-definition)
+(put 'if 'eval eval-if)
+(put 'lambda
+ 'eval
+ (lambda (exp env)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env)))
+(put 'begin
+ 'eval
+ (lambda (exp env)
+ (eval-sequence (begin-actions exp) env)))
+(put 'cond
+ 'eval
+ (lambda (exp env)
+ (eval (cond->if exp) env)))
+(put 'let
+ 'eval
+ (lambda (exp env)
+ (eval (let->combination exp) env)))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; test-suite
+
+(test-case (geval '(begin 5 6)) 6)
+(test-case (geval '10) 10)
+(geval '(define x 3))
+(test-case (geval 'x) 3)
+(test-case (geval '(set! x -25)) 'ok)
+(test-case (geval 'x) -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-case (geval '(z 3 4)) 15)
+(test-case (geval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-case (geval '(if true false true)) false)
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+
+
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-case (geval '(factorial 5)) 120)
+
+
blob - /dev/null
blob + bdd9a435644a18371478609d8868db4ec57412a8 (mode 644)
--- /dev/null
+++ ex4-3.scm~
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; Exercise 4.2. Louis Reasoner plans to reorder the cond clauses in eval so that the clause for procedure applications appears before the clause for assignments. He argues that this will make the interpreter more efficient: Since programs usually contain more applications than assignments, definitions, and so on, his modified eval will usually check fewer clauses than the original eval before identifying the type of an expression.
+
+;; a. What is wrong with Louis's plan? (Hint: What will Louis's evaluator do with the expression (define x 3)?)
+
+;; the define special form will be interpreted as an application because the only requirement is that the expression be a pair
+
+;; b. Louis is upset that his plan didn't work. He is willing to go to any lengths to make his evaluator recognize procedure applications before it checks for most other kinds of expressions. Help him by changing the syntax of the evaluated language so that procedure applications start with call. For example, instead of (factorial 3) we will now have to write (call factorial 3) and instead of (+ 1 2) we will have to write (call + 1 2).
+
+(define (application? exp) (tagged-list? exp 'call))
+(define (operator exp) (cadr exp))
+(define (operands exp) (cddr exp))
+(define (make-application op args)
+ (cons 'call (cons op args)))
+(geval
+ '(define (factorial n)
+ (if (call = n 0)
+ 1
+ (call * n (call factorial (call - n 1))))))
+(test-case (geval '(call factorial 5)) 120)
+
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (call + x y (call * x y))))
+ (+ 4 7 (* 4 7)))
blob - /dev/null
blob + d232d12b4bfbfb3f8725600704b491b89f108f98 (mode 644)
--- /dev/null
+++ ex4-30.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+
+;; Exercise 4.30. Cy D. Fect, a reformed C programmer, is worried that some side effects may never take place, because the lazy evaluator doesn't force the expressions in a sequence. Since the value of an expression in a sequence other than the last one is not used (the expression is there only for its effect, such as assigning to a variable or printing), there can be no subsequent use of this value (e.g., as an argument to a primitive procedure) that will cause it to be forced. Cy thus thinks that when evaluating sequences, we must force all expressions in the sequence except the final one. He proposes to modify eval-sequence from section 4.1.1 to use actual-value rather than eval:
+
+;; (define (eval-sequence exps env)
+;; (cond ((last-exp? exps) (eval (first-exp exps) env))
+;; (else (actual-value (first-exp exps) env)
+;; (eval-sequence (rest-exps exps) env))))
+
+;; a. Ben Bitdiddle thinks Cy is wrong. He shows Cy the for-each procedure described in exercise 2.23, which gives an important example of a sequence with side effects:
+
+;; (define (for-each proc items)
+;; (if (null? items)
+;; 'done
+;; (begin (proc (car items))
+;; (for-each proc (cdr items)))))
+
+;; He claims that the evaluator in the text (with the original eval-sequence) handles this correctly:
+
+;;; L-Eval input:
+;; (for-each (lambda (x) (newline) (display x))
+;; (list 57 321 88))
+;; 57
+;; 321
+;; 88
+;; ;;; L-Eval value:
+;; done
+
+;; Explain why Ben is right about the behavior of for-each.
+
+;; proc is an operator and hence the thunk will be forced for proc
+;; display is a primitive and this will therefore force the thunk for (car items)
+
+;; b. Cy agrees that Ben is right about the for-each example, but says that that's not the kind of program he was thinking about when he proposed his change to eval-sequence. He defines the following two procedures in the lazy evaluator:
+
+(geval
+ '(define (p1 x)
+ (set! x (cons x '(2)))
+ x))
+(geval
+ '(define (p2 x)
+ (define (p e)
+ e
+ x)
+ (p (set! x (cons x '(2))))))
+(test-eval '(p1 1) '(1 2))
+(test-eval '(p2 1) 1)
+
+;; What are the values of (p1 1) and (p2 1) with the original eval-sequence? What would the values be with Cy's proposed change to eval-sequence?
+
+;; with Cy's change, it would be '(1 2) for both
+
+;; c. Cy also points out that changing eval-sequence as he proposes does not affect the behavior of the example in part a. Explain why this is true.
+
+;; the primitives were forcing the evaluation of the thunks anyway
+
+;; d. How do you think sequences ought to be treated in the lazy evaluator? Do you like Cy's approach, the approach in the text, or some other approach?
+
+;; The one in the text is better. Cy's approach would partially defeat the whole purpose of delayed evaluation.
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
blob - /dev/null
blob + d232d12b4bfbfb3f8725600704b491b89f108f98 (mode 644)
--- /dev/null
+++ ex4-30.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+
+;; Exercise 4.30. Cy D. Fect, a reformed C programmer, is worried that some side effects may never take place, because the lazy evaluator doesn't force the expressions in a sequence. Since the value of an expression in a sequence other than the last one is not used (the expression is there only for its effect, such as assigning to a variable or printing), there can be no subsequent use of this value (e.g., as an argument to a primitive procedure) that will cause it to be forced. Cy thus thinks that when evaluating sequences, we must force all expressions in the sequence except the final one. He proposes to modify eval-sequence from section 4.1.1 to use actual-value rather than eval:
+
+;; (define (eval-sequence exps env)
+;; (cond ((last-exp? exps) (eval (first-exp exps) env))
+;; (else (actual-value (first-exp exps) env)
+;; (eval-sequence (rest-exps exps) env))))
+
+;; a. Ben Bitdiddle thinks Cy is wrong. He shows Cy the for-each procedure described in exercise 2.23, which gives an important example of a sequence with side effects:
+
+;; (define (for-each proc items)
+;; (if (null? items)
+;; 'done
+;; (begin (proc (car items))
+;; (for-each proc (cdr items)))))
+
+;; He claims that the evaluator in the text (with the original eval-sequence) handles this correctly:
+
+;;; L-Eval input:
+;; (for-each (lambda (x) (newline) (display x))
+;; (list 57 321 88))
+;; 57
+;; 321
+;; 88
+;; ;;; L-Eval value:
+;; done
+
+;; Explain why Ben is right about the behavior of for-each.
+
+;; proc is an operator and hence the thunk will be forced for proc
+;; display is a primitive and this will therefore force the thunk for (car items)
+
+;; b. Cy agrees that Ben is right about the for-each example, but says that that's not the kind of program he was thinking about when he proposed his change to eval-sequence. He defines the following two procedures in the lazy evaluator:
+
+(geval
+ '(define (p1 x)
+ (set! x (cons x '(2)))
+ x))
+(geval
+ '(define (p2 x)
+ (define (p e)
+ e
+ x)
+ (p (set! x (cons x '(2))))))
+(test-eval '(p1 1) '(1 2))
+(test-eval '(p2 1) 1)
+
+;; What are the values of (p1 1) and (p2 1) with the original eval-sequence? What would the values be with Cy's proposed change to eval-sequence?
+
+;; with Cy's change, it would be '(1 2) for both
+
+;; c. Cy also points out that changing eval-sequence as he proposes does not affect the behavior of the example in part a. Explain why this is true.
+
+;; the primitives were forcing the evaluation of the thunks anyway
+
+;; d. How do you think sequences ought to be treated in the lazy evaluator? Do you like Cy's approach, the approach in the text, or some other approach?
+
+;; The one in the text is better. Cy's approach would partially defeat the whole purpose of delayed evaluation.
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
blob - /dev/null
blob + 370574971b2a31db9d80842130c9a22f536f0104 (mode 644)
--- /dev/null
+++ ex4-31.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args
+ (procedure-parameters-directives procedure)
+ arguments
+ env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (simple-thunk? obj)
+ (tagged-list? obj 'simple-thunk))
+(define (simple-delay-it exp env)
+ `(simple-thunk ,exp ,env))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ ((simple-thunk? obj)
+ (actual-value (thunk-exp obj)
+ (thunk-env obj)))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args directives exps env)
+ (if (no-operands? exps)
+ '()
+ (let* ((directive (car directives))
+ (op (first-operand exps))
+ (arg (cond ((eq? directive 'strict)
+ (eval op env))
+ ((eq? directive 'lazy)
+ (simple-delay-it op env))
+ ((eq? directive 'lazy-memo)
+ (delay-it op env))
+ (else
+ (error "Unknown directive " directive)))))
+ (cons arg
+ (list-of-delayed-args
+ (cdr directives)
+ (cdr exps)
+ env)))))
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+;; (define (procedure-parameters p) (cadr p))
+(define (procedure-parameters p)
+ (map (lambda (param)
+ (if (symbol? param)
+ param
+ (car param)))
+ (cadr p)))
+(define (procedure-parameters-directives p)
+ (map (lambda (param)
+ (if (symbol? param)
+ 'strict
+ (cadr param)))
+ (cadr p)))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; Exercise 4.31. The approach taken in this section is somewhat unpleasant, because it makes a3n incompatible change to Scheme. It might be nicer to implement lazy evaluation as an upward-compatible extension, that is, so that ordinary Scheme programs will work as before. We can do this by extending the syntax of procedure declarations to let the user control whether or not arguments are to be delayed. While we're at it, we may as well also give the user the choice between delaying with and without memoization. For example, the definition
+
+;; (define (f a (b lazy) c (d lazy-memo))
+;; ...)
+
+;; would define f to be a procedure of four arguments, where the first and third arguments are evaluated when the procedure is called, the second argument is delayed, and the fourth argument is both delayed and memoized. Thus, ordinary procedure definitions will produce the same behavior as ordinary Scheme, while adding the lazy-memo declaration to each parameter of every compound procedure will produce the behavior of the lazy evaluator defined in this section. Design and implement the changes required to produce such an extension to Scheme. You will have to implement new syntax procedures to handle the new syntax for define. You must also arrange for eval or apply to determine when arguments are to be delayed, and to force or delay arguments accordingly, and you must arrange for forcing to memoize or not, as appropriate.
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try (a lazy-memo) (b lazy-memo))
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless (condition lazy-memo) (usual-value lazy-memo) (exceptional-value lazy-memo))
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial (n lazy-memo))
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id (x lazy-memo))
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id (x lazy-memo))
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square (x lazy-memo))
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+(geval
+ '(define (p1 (x lazy-memo))
+ (set! x (cons x '(2)))
+ x))
+(geval
+ '(define (p2 (x lazy-memo))
+ (define (p e)
+ e
+ x)
+ (p (set! x (cons x '(2))))))
+(test-eval '(p1 1) '(1 2))
+(test-eval '(p2 1) 1)
+
+(geval '(define count 0))
+
+(geval
+ '(define (id (x lazy-memo))
+ (set! count (+ count 1))
+ x))
+
+(geval
+ '(define (f a (b lazy) c (d lazy-memo))
+ a
+ b
+ c
+ d))
+(test-eval
+ '(f (id 1) (id 2) (id 3) (id 4))
+ 4)
+(test-eval 'count 3)
+(test-eval
+ '(f 1 (id 2) 3 4)
+ 4)
+(test-eval 'count 3)
+(geval
+ '(define (g (a lazy-memo))
+ (+ a a)))
+(test-eval
+ '(g (id 2))
+ 4)
+(test-eval 'count 4)
+(geval
+ '(define (h (a lazy))
+ (+ a a)))
+(test-eval
+ '(h (id 2))
+ 4)
+(test-eval 'count 6)
+(test-eval
+ '(g (id (id 2)))
+ 4)
+(test-eval 'count 8)
+
+(test-eval
+ '(h (id (id 2)))
+ 4)
+(test-eval
+ 'count
+ 12)
+(geval
+ '(define (i a)
+ (+ a a)))
+(test-eval
+ '(i (id 2))
+ 4)
+(test-eval
+ 'count
+ 13)
+(test-eval
+ '(i (id (id 2)))
+ 4)
+(test-eval 'count 15)
+(geval
+ '(define (add-to-count (n lazy-memo))
+ (if (= n 0)
+ 0
+ (begin (set! count (+ count 1))
+ (add-to-count (- n 1))))))
+(geval
+ '(define (subtract-from-count (n lazy))
+ (if (= n 0)
+ 0
+ (begin (set! count (- count 1))
+ (subtract-from-count (- n 1))))))
+(test-eval
+ '(add-to-count (id 5))
+ 0)
+(test-eval 'count 21)
+;; n = (thunk (id 5))
+;; count = 16
+;; count = 17
+;; (add-to-count (- n 1))
+;; n = (thunk (- n 1))
+;; n = 4
+;; count = 18
+;; n = 3
+;; count = 19
+;; n = 2
+;; count = 20
+;; n = 1
+;; count = 21
+;; n = 0
+(test-eval
+ '(subtract-from-count (id 5))
+ 0)
+;; n = (simple-thunk (id 5))
+;; count = 22
+;; (= 5 0)
+;; count = 21
+;; (subtract-from-count (- n 1))
+;; n = (simple-thunk (- n 1))
+;; n = (- n 1)
+;; count = 22
+;; n = 4
+;; count = 21
+;; (subtract-from-count (- n 1))
+;; n = (simple-thunk (- n 1))
+;; count = 22
+;; n = 3
+;; count = 21
+;; (subtract-from-count (- n 1))
+;; n = (simple-thunk (- n 1))
+;; count = 22
+;; n = 2
+;; count = 21
+;; ...
+;; count = 22
+;; n = 0
+(test-eval 'count 22)
blob - /dev/null
blob + 20ce14dae501a8bfe2a4df655f44f680e0d73857 (mode 644)
--- /dev/null
+++ ex4-31.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args
+ (procedure-parameters-directives procedure)
+ arguments
+ env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (simple-thunk? obj)
+ (tagged-list? obj 'simple-thunk))
+(define (simple-delay-it exp env)
+ `(simple-thunk ,exp ,env))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ ((simple-thunk? obj)
+ (actual-value (thunk-exp obj)
+ (thunk-env obj)))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args directives exps env)
+ (if (no-operands? exps)
+ '()
+ (let ((directive (car directives))
+ (op (first-operand exps)))
+ (cond ((eq? directive 'strict)
+ (cons (eval op env)
+ (list-of-delayed-args
+ (cdr directives)
+ (cdr exps)
+ env)))
+ ((eq? directive 'lazy)
+ (cons (simple-delay-it op env)
+ (list-of-delayed-args
+ (cdr directives)
+ (cdr exps)
+ env)))
+ ((eq? directive 'lazy-memo)
+ (cons (delay-it op env)
+ (list-of-delayed-args
+ (cdr directives)
+ (cdr exps)
+ env)))))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+;; (define (procedure-parameters p) (cadr p))
+(define (procedure-parameters p)
+ (map (lambda (param)
+ (if (symbol? param)
+ param
+ (car param)))
+ (cadr p)))
+(define (procedure-parameters-directives p)
+ (map (lambda (param)
+ (if (symbol? param)
+ 'strict
+ (cadr param)))
+ (cadr p)))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; Exercise 4.31. The approach taken in this section is somewhat unpleasant, because it makes an incompatible change to Scheme. It might be nicer to implement lazy evaluation as an upward-compatible extension, that is, so that ordinary Scheme programs will work as before. We can do this by extending the syntax of procedure declarations to let the user control whether or not arguments are to be delayed. While we're at it, we may as well also give the user the choice between delaying with and without memoization. For example, the definition
+
+(define (f a (b lazy) c (d lazy-memo))
+ ...)
+
+;; would define f to be a procedure of four arguments, where the first and third arguments are evaluated when the procedure is called, the second argument is delayed, and the fourth argument is both delayed and memoized. Thus, ordinary procedure definitions will produce the same behavior as ordinary Scheme, while adding the lazy-memo declaration to each parameter of every compound procedure will produce the behavior of the lazy evaluator defined in this section. Design and implement the changes required to produce such an extension to Scheme. You will have to implement new syntax procedures to handle the new syntax for define. You must also arrange for eval or apply to determine when arguments are to be delayed, and to force or delay arguments accordingly, and you must arrange for forcing to memoize or not, as appropriate.
+
+(geval '(define count 0))
+
+(geval
+ '(define (id (x lazy-memo))
+ (set! count (+ count 1))
+ x))
+
+(geval
+ '(define (f a (b lazy) c (d lazy-memo))
+ a
+ b
+ c
+ d))
+(test-eval
+ '(f (id 1) (id 2) (id 3) (id 4))
+ 4)
+(test-eval 'count 3)
+(test-eval
+ '(f 1 (id 2) 3 4)
+ 4)
+(test-eval 'count 3)
+(geval
+ '(define (g (a lazy-memo))
+ (+ a a)))
+(test-eval
+ '(g (id 2))
+ 4)
+(test-eval 'count 4)
+(geval
+ '(define (h (a lazy))
+ (+ a a)))
+(test-eval
+ '(h (id 2))
+ 4)
+(test-eval 'count 6)
+(test-eval
+ '(g (id (id 2)))
+ ...)
+(test-eval 'count ...)
+(test-eval
+ '(h (id (id 2)))
+ ...)
+(test-eval
+ 'count
+ ...)
+(geval
+ '(define (i a)
+ (+ a a)))
+(test-eval
+ '(i (id 2))
+ ...)
+(test-eval
+ 'count
+ ...)
+(test-eval
+ '(i (id (id 2)))
+ ...)
+(test-eval
+ 'count
+ ...)
+(define (add-to-count (n lazy-memo)
+ (if (= n 0)
+ 0
+ (begin (set! count (+ count 1))
+ (add-to-count (- n 1)))))
+(define (subtract-from-count (n lazy))
+ (if (= n 0)
+ 0
+ (begin (set! count (- count 1))
+ (subtract-from-count (- n 1)))))
+(test-eval
+ '(add-to-count (id 5))
+ ...)
+(test-eval
+ '(subtract-from-count (id 5))
+ ...)
+(test-eval 'count ...)
+(define (lazy-add (n
+ '(define (f a (b lazy) c (d lazy-memo))
+ a
+ b
+ c
+ d))
+
+(test-eval
+ '(f (id 1) (id 2) (id 3) (id 4))
+ 4)
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+(geval
+ '(define (p1 x)
+ (set! x (cons x '(2)))
+ x))
+(geval
+ '(define (p2 x)
+ (define (p e)
+ e
+ x)
+ (p (set! x (cons x '(2))))))
+(test-eval '(p1 1) '(1 2))
+(test-eval '(p2 1) 1)
blob - /dev/null
blob + 06f029fc00c7b16920db91c058aff0b2aea03600 (mode 644)
--- /dev/null
+++ ex4-32-2.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
blob - /dev/null
blob + 0685c30880306406aab1d783dc439eed96d60308 (mode 644)
--- /dev/null
+++ ex4-32-2.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(define (cons x y)
+ (lambda (m) (m x y)))
+(define (car z)
+ (z (lambda (p q) p)))
+(define (cdr z)
+ (z (lambda (p q) q)))
+
+(define x (cons 3 5))
+;; x = (thunk 3)
+;; y = (thunk 5)
+;; x = procedure object
+
+
+;; (car x)
+;; z = (thunk x)
+;; z = procedure object
+;; m = (thunk (lambda (p q) p))
+;; (m x y)
+;; m = (procedure (p q) (p) env)
+;; p = (thunk x)
+;; q = (thunk y)
+;; (thunk x)
+;; (thunk 3)
+;; 3
+
+(define (cons x y)
+ (lambda (m) (m x y)))
+(define (car z)
+ (z (lambda (p q) p)))
+(define (cdr z)
+ (z (lambda (p q) q)))
+(define a (cons 8 2))
+
+;; x = (thunk 8)
+;; y = (thunk 2)
+;; a = (procedure (m) ((m x y)) <env>)
+
+(cdr a)
+
+;; z = (thunk a)
+;; (z (lambda (p q) q))
+;; z = (procedure (m) ((m x y)) <env>)
+;; m = (thunk (lambda (p q) q))
+;; (m x y)
+;; m = (procedure (p q) (q) <env>)
+;; p = (thunk x)
+;; q = (thunk y)
+;; (thunk y)
+;; (thunk 2)
+;; 2
+
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
blob - /dev/null
blob + 0685c30880306406aab1d783dc439eed96d60308 (mode 644)
--- /dev/null
+++ ex4-32.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(define (cons x y)
+ (lambda (m) (m x y)))
+(define (car z)
+ (z (lambda (p q) p)))
+(define (cdr z)
+ (z (lambda (p q) q)))
+
+(define x (cons 3 5))
+;; x = (thunk 3)
+;; y = (thunk 5)
+;; x = procedure object
+
+
+;; (car x)
+;; z = (thunk x)
+;; z = procedure object
+;; m = (thunk (lambda (p q) p))
+;; (m x y)
+;; m = (procedure (p q) (p) env)
+;; p = (thunk x)
+;; q = (thunk y)
+;; (thunk x)
+;; (thunk 3)
+;; 3
+
+(define (cons x y)
+ (lambda (m) (m x y)))
+(define (car z)
+ (z (lambda (p q) p)))
+(define (cdr z)
+ (z (lambda (p q) q)))
+(define a (cons 8 2))
+
+;; x = (thunk 8)
+;; y = (thunk 2)
+;; a = (procedure (m) ((m x y)) <env>)
+
+(cdr a)
+
+;; z = (thunk a)
+;; (z (lambda (p q) q))
+;; z = (procedure (m) ((m x y)) <env>)
+;; m = (thunk (lambda (p q) q))
+;; (m x y)
+;; m = (procedure (p q) (q) <env>)
+;; p = (thunk x)
+;; q = (thunk y)
+;; (thunk y)
+;; (thunk 2)
+;; 2
+
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
blob - /dev/null
blob + d232d12b4bfbfb3f8725600704b491b89f108f98 (mode 644)
--- /dev/null
+++ ex4-32.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+
+;; Exercise 4.30. Cy D. Fect, a reformed C programmer, is worried that some side effects may never take place, because the lazy evaluator doesn't force the expressions in a sequence. Since the value of an expression in a sequence other than the last one is not used (the expression is there only for its effect, such as assigning to a variable or printing), there can be no subsequent use of this value (e.g., as an argument to a primitive procedure) that will cause it to be forced. Cy thus thinks that when evaluating sequences, we must force all expressions in the sequence except the final one. He proposes to modify eval-sequence from section 4.1.1 to use actual-value rather than eval:
+
+;; (define (eval-sequence exps env)
+;; (cond ((last-exp? exps) (eval (first-exp exps) env))
+;; (else (actual-value (first-exp exps) env)
+;; (eval-sequence (rest-exps exps) env))))
+
+;; a. Ben Bitdiddle thinks Cy is wrong. He shows Cy the for-each procedure described in exercise 2.23, which gives an important example of a sequence with side effects:
+
+;; (define (for-each proc items)
+;; (if (null? items)
+;; 'done
+;; (begin (proc (car items))
+;; (for-each proc (cdr items)))))
+
+;; He claims that the evaluator in the text (with the original eval-sequence) handles this correctly:
+
+;;; L-Eval input:
+;; (for-each (lambda (x) (newline) (display x))
+;; (list 57 321 88))
+;; 57
+;; 321
+;; 88
+;; ;;; L-Eval value:
+;; done
+
+;; Explain why Ben is right about the behavior of for-each.
+
+;; proc is an operator and hence the thunk will be forced for proc
+;; display is a primitive and this will therefore force the thunk for (car items)
+
+;; b. Cy agrees that Ben is right about the for-each example, but says that that's not the kind of program he was thinking about when he proposed his change to eval-sequence. He defines the following two procedures in the lazy evaluator:
+
+(geval
+ '(define (p1 x)
+ (set! x (cons x '(2)))
+ x))
+(geval
+ '(define (p2 x)
+ (define (p e)
+ e
+ x)
+ (p (set! x (cons x '(2))))))
+(test-eval '(p1 1) '(1 2))
+(test-eval '(p2 1) 1)
+
+;; What are the values of (p1 1) and (p2 1) with the original eval-sequence? What would the values be with Cy's proposed change to eval-sequence?
+
+;; with Cy's change, it would be '(1 2) for both
+
+;; c. Cy also points out that changing eval-sequence as he proposes does not affect the behavior of the example in part a. Explain why this is true.
+
+;; the primitives were forcing the evaluation of the thunks anyway
+
+;; d. How do you think sequences ought to be treated in the lazy evaluator? Do you like Cy's approach, the approach in the text, or some other approach?
+
+;; The one in the text is better. Cy's approach would partially defeat the whole purpose of delayed evaluation.
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
blob - /dev/null
blob + 6f84bc77f651135bea043ea2e13a16711ab5ddd7 (mode 644)
--- /dev/null
+++ ex4-33-2.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((quoted-pair? exp) (eval (quoted-pair->cons (text-of-quotation exp)) env))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (and (tagged-list? exp 'quote)
+ (not (pair? (cadr exp)))))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; Exercise 4.33. Ben Bitdiddle tests the lazy list implementation given above by evaluating the expression
+
+(define (quoted-pair? exp)
+ (and (tagged-list? exp 'quote)
+ (pair? (cadr exp))))
+
+(define (quoted-pair->cons exp)
+ (if (pair? exp)
+ (make-cons (quoted-pair->cons (car exp))
+ (quoted-pair->cons (cdr exp)))
+ (make-quote exp)))
+(define (make-quote exp)
+ `(quote ,exp))
+(define (make-cons x y)
+ `(cons ,x ,y))
+
+(test-case
+ (quoted-pair->cons '(a))
+ '(cons 'a '()))
+(test-case
+ (quoted-pair->cons '(a b c))
+ '(cons 'a (cons 'b (cons 'c '()))))
+(test-case
+ (quoted-pair->cons
+ '((a b) c))
+ '(cons (cons 'a (cons 'b '())) (cons 'c '())))
+(test-case
+ (quoted-pair->cons
+ '((a c) (b d)))
+ '(cons (cons 'a (cons 'c '()))
+ (cons (cons 'b (cons 'd '())) '())))
+(test-case
+ (quoted-pair->cons
+ '(((a b) (c d (e)) f) g))
+ '(cons (cons (cons 'a (cons 'b '()))
+ (cons (cons 'c (cons 'd (cons (cons 'e '())
+ '())))
+ (cons 'f '())))
+ (cons 'g '())))
+
+
+;; (car '(a b c))
+
+;; if we have a quoted list, we need to transform it into the proper cons
+
+;; To his surprise, this produces an error. After some thought, he realizes that the ``lists'' obtained by reading in quoted expressions are different from the lists manipulated by the new definitions of cons, car, and cdr. Modify the evaluator's treatment of quoted expressions so that quoted lists typed at the driver loop will produce true lazy lists.
+
+;; (quote (a))
+(test-eval
+ '(car (cons (quote a) (quote ())))
+ 'a)
+(test-eval
+ '(cdr (cons (quote a) (quote ())))
+ '())
+(test-eval
+ '(car '(a))
+ 'a)
+(test-eval
+ '(cdr '(a))
+ '())
+(test-eval
+ '(car (cdr '(a b)))
+ 'b)
+(test-eval
+ '(car (car '((a b) c)))
+ 'a)
+(test-eval
+ '(car (cdr (car (cdr '((a c) (b d))))))
+ 'd)
+
+
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+
+
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(test-eval
+ '(car (cdr (add-lists '(1 2 3 4 5) '(2 3 4 5 6))))
+ 5)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+
+;; streams
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
blob - /dev/null
blob + 94e77ecf83243f23fee2c7122979098d5ebbedeb (mode 644)
--- /dev/null
+++ ex4-33-2.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((quoted-pair? exp) (eval (quoted-pair->cons (text-of-quotation exp)) env))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (and (tagged-list? exp 'quote)
+ (not (pair? (cadr exp)))))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; Exercise 4.33. Ben Bitdiddle tests the lazy list implementation given above by evaluating the expression
+
+(define (quoted-pair? exp)
+ (and (tagged-list? exp 'quote)
+ (pair? (cadr exp))))
+
+(define (quoted-pair->cons exp)
+ (if (pair? exp)
+ (make-cons (quoted-pair->cons (car exp))
+ (quoted-pair->cons (cdr exp)))
+ (make-quote exp)))
+(define (make-quote exp)
+ `(quote ,exp))
+(define (make-cons x y)
+ `(cons ,x ,y))
+
+(test-case
+ (quoted-pair->cons '(a))
+ '(cons 'a '()))
+(test-case
+ (quoted-pair->cons '(a b c))
+ '(cons 'a (cons 'b (cons 'c '()))))
+(test-case
+ (quoted-pair->cons
+ '((a b) c))
+ '(cons (cons 'a (cons 'b '())) (cons 'c '())))
+(test-case
+ (quoted-pair->cons
+ '((a c) (b d)))
+ '(cons (cons 'a (cons 'c '()))
+ (cons (cons 'b (cons 'd '())) '())))
+(test-case
+ (quoted-pair->cons
+ '(((a b) (c d (e)) f) g))
+ '(cons (cons (cons 'a (cons 'b '()))
+ (cons (cons 'c (cons 'd (cons (cons 'e '())
+ '())))
+ (cons 'f '())))
+ (cons 'g '())))
+
+
+;; (car '(a b c))
+
+;; if we have a quoted list, we need to transform it into the proper cons
+
+;; To his surprise, this produces an error. After some thought, he realizes that the ``lists'' obtained by reading in quoted expressions are different from the lists manipulated by the new definitions of cons, car, and cdr. Modify the evaluator's treatment of quoted expressions so that quoted lists typed at the driver loop will produce true lazy lists.
+
+;; (quote (a))
+(test-eval
+ '(car (cons (quote a) (quote ())))
+ 'a)
+(test-eval
+ '(cdr (cons (quote a) (quote ())))
+ '())
+(test-eval
+ '(car '(a))
+ 'a)
+(test-eval
+ '(cdr '(a))
+ '())
+(test-eval
+ '(car (cdr '(a b)))
+ 'a)
+(test-eval
+ '(car (car '((a b) c)))
+ 'a)
+(test-eval
+ '(car (cdr (car (cdr '((a c) (b d))))))
+ 'd)
+
+
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+
+
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(test-eval
+ '(car (cdr (add-lists '(1 2 3 4 5) '(2 3 4 5 6))))
+ 5)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+
+;; streams
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
blob - /dev/null
blob + fd047fe7e39129709de03b48d9adfad213e84e09 (mode 644)
--- /dev/null
+++ ex4-33-3.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((quoted-list? exp) (eval (list->cons (text-of-quotation exp)) env))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (and (tagged-list? exp 'quote)
+ (not (pair? (cadr exp)))))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; Exercise 4.33. Ben Bitdiddle tests the lazy list implementation given above by evaluating the expression
+
+(define (quoted-list? exp)
+ (and (tagged-list? exp 'quote)
+ (pair? (cadr exp))))
+
+(define (list->cons exp)
+ (if (pair? exp)
+ (make-cons (list->cons (car exp))
+ (list->cons (cdr exp)))
+ (make-quote exp)))
+(define (make-quote exp)
+ `(quote ,exp))
+(define (make-cons x y)
+ `(cons ,x ,y))
+
+(test-case
+ (list->cons '(a))
+ '(cons 'a '()))
+(test-case
+ (list->cons '(a b c))
+ '(cons 'a (cons 'b (cons 'c '()))))
+(test-case
+ (list->cons
+ '((a b) c))
+ '(cons (cons 'a (cons 'b '())) (cons 'c '())))
+(test-case
+ (list->cons
+ '((a c) (b d)))
+ '(cons (cons 'a (cons 'c '()))
+ (cons (cons 'b (cons 'd '())) '())))
+(test-case
+ (list->cons
+ '(((a b) (c d (e)) f) g))
+ '(cons (cons (cons 'a (cons 'b '()))
+ (cons (cons 'c (cons 'd (cons (cons 'e '())
+ '())))
+ (cons 'f '())))
+ (cons 'g '())))
+
+
+;; (car '(a b c))
+
+;; if we have a quoted list, we need to transform it into the proper cons
+
+;; To his surprise, this produces an error. After some thought, he realizes that the ``lists'' obtained by reading in quoted expressions are different from the lists manipulated by the new definitions of cons, car, and cdr. Modify the evaluator's treatment of quoted expressions so that quoted lists typed at the driver loop will produce true lazy lists.
+
+;; (quote (a))
+(test-eval
+ '(car (cons (quote a) (quote ())))
+ 'a)
+(test-eval
+ '(cdr (cons (quote a) (quote ())))
+ '())
+(test-eval
+ '(car '(a))
+ 'a)
+(test-eval
+ '(cdr '(a))
+ '())
+(test-eval
+ '(car (cdr '(a b)))
+ 'b)
+(test-eval
+ '(car (car '((a b) c)))
+ 'a)
+(test-eval
+ '(car (cdr (car (cdr '((a c) (b d))))))
+ 'd)
+
+
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+
+
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(test-eval
+ '(car (cdr (add-lists '(1 2 3 4 5) '(2 3 4 5 6))))
+ 5)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+
+;; streams
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
blob - /dev/null
blob + 6f84bc77f651135bea043ea2e13a16711ab5ddd7 (mode 644)
--- /dev/null
+++ ex4-33-3.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((quoted-pair? exp) (eval (quoted-pair->cons (text-of-quotation exp)) env))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (and (tagged-list? exp 'quote)
+ (not (pair? (cadr exp)))))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; Exercise 4.33. Ben Bitdiddle tests the lazy list implementation given above by evaluating the expression
+
+(define (quoted-pair? exp)
+ (and (tagged-list? exp 'quote)
+ (pair? (cadr exp))))
+
+(define (quoted-pair->cons exp)
+ (if (pair? exp)
+ (make-cons (quoted-pair->cons (car exp))
+ (quoted-pair->cons (cdr exp)))
+ (make-quote exp)))
+(define (make-quote exp)
+ `(quote ,exp))
+(define (make-cons x y)
+ `(cons ,x ,y))
+
+(test-case
+ (quoted-pair->cons '(a))
+ '(cons 'a '()))
+(test-case
+ (quoted-pair->cons '(a b c))
+ '(cons 'a (cons 'b (cons 'c '()))))
+(test-case
+ (quoted-pair->cons
+ '((a b) c))
+ '(cons (cons 'a (cons 'b '())) (cons 'c '())))
+(test-case
+ (quoted-pair->cons
+ '((a c) (b d)))
+ '(cons (cons 'a (cons 'c '()))
+ (cons (cons 'b (cons 'd '())) '())))
+(test-case
+ (quoted-pair->cons
+ '(((a b) (c d (e)) f) g))
+ '(cons (cons (cons 'a (cons 'b '()))
+ (cons (cons 'c (cons 'd (cons (cons 'e '())
+ '())))
+ (cons 'f '())))
+ (cons 'g '())))
+
+
+;; (car '(a b c))
+
+;; if we have a quoted list, we need to transform it into the proper cons
+
+;; To his surprise, this produces an error. After some thought, he realizes that the ``lists'' obtained by reading in quoted expressions are different from the lists manipulated by the new definitions of cons, car, and cdr. Modify the evaluator's treatment of quoted expressions so that quoted lists typed at the driver loop will produce true lazy lists.
+
+;; (quote (a))
+(test-eval
+ '(car (cons (quote a) (quote ())))
+ 'a)
+(test-eval
+ '(cdr (cons (quote a) (quote ())))
+ '())
+(test-eval
+ '(car '(a))
+ 'a)
+(test-eval
+ '(cdr '(a))
+ '())
+(test-eval
+ '(car (cdr '(a b)))
+ 'b)
+(test-eval
+ '(car (car '((a b) c)))
+ 'a)
+(test-eval
+ '(car (cdr (car (cdr '((a c) (b d))))))
+ 'd)
+
+
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+
+
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(test-eval
+ '(car (cdr (add-lists '(1 2 3 4 5) '(2 3 4 5 6))))
+ 5)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+
+;; streams
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
blob - /dev/null
blob + 2ab93c78e0debd5818ba5ea4b8de5efae2d11879 (mode 644)
--- /dev/null
+++ ex4-33-4.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((quoted-list? exp) (eval (list->cons (text-of-quotation exp)) env))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (and (tagged-list? exp 'quote)
+ (not (pair? (cadr exp)))))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; Exercise 4.33. Ben Bitdiddle tests the lazy list implementation given above by evaluating the expression
+
+(define (quoted-list? exp)
+ (and (tagged-list? exp 'quote)
+ (pair? (cadr exp))))
+
+(define (list->cons exp)
+ (if (pair? exp)
+ (make-cons (list->cons (car exp))
+ (list->cons (cdr exp)))
+ (make-quote exp)))
+(define (make-quote exp)
+ `(quote ,exp))
+(define (make-cons x y)
+ `(cons ,x ,y))
+
+;; (car '(a b c))
+
+;; if we have a quoted list, we need to transform it into the proper cons
+
+;; To his surprise, this produces an error. After some thought, he realizes that the ``lists'' obtained by reading in quoted expressions are different from the lists manipulated by the new definitions of cons, car, and cdr. Modify the evaluator's treatment of quoted expressions so that quoted lists typed at the driver loop will produce true lazy lists.
+
+;; (quote (a))
+(test-eval
+ '(car (cons (quote a) (quote ())))
+ 'a)
+(test-eval
+ '(cdr (cons (quote a) (quote ())))
+ '())
+(test-eval
+ '(car '(a))
+ 'a)
+(test-eval
+ '(cdr '(a))
+ '())
+(test-eval
+ '(car (cdr '(a b)))
+ 'b)
+(test-eval
+ '(car (car '((a b) c)))
+ 'a)
+(test-eval
+ '(car (cdr (car (cdr '((a c) (b d))))))
+ 'd)
+
+
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+
+
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(test-eval
+ '(car (cdr (add-lists '(1 2 3 4 5) '(2 3 4 5 6))))
+ 5)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+
+;; streams
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
blob - /dev/null
blob + 1986a9d4003c16e439cd76ebe730ace1af204438 (mode 644)
--- /dev/null
+++ ex4-33-4.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((quoted-list? exp) (eval (list->cons (text-of-quotation exp)) env))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (and (tagged-list? exp 'quote)
+ (not (pair? (cadr exp)))))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; Exercise 4.33. Ben Bitdiddle tests the lazy list implementation given above by evaluating the expression
+
+(define (quoted-list? exp)
+ (and (tagged-list? exp 'quote)
+ (pair? (cadr exp))))
+
+(define (list->cons exp)
+ (if (pair? exp)
+ (make-cons (list->cons (car exp))
+ (list->cons (cdr exp)))
+ (make-quote exp)))
+(define (make-quote exp)
+ `(quote ,exp))
+(define (make-cons x y)
+ `(cons ,x ,y))
+
+
+
+;; (car '(a b c))
+
+;; if we have a quoted list, we need to transform it into the proper cons
+
+;; To his surprise, this produces an error. After some thought, he realizes that the ``lists'' obtained by reading in quoted expressions are different from the lists manipulated by the new definitions of cons, car, and cdr. Modify the evaluator's treatment of quoted expressions so that quoted lists typed at the driver loop will produce true lazy lists.
+
+;; (quote (a))
+(test-eval
+ '(car (cons (quote a) (quote ())))
+ 'a)
+(test-eval
+ '(cdr (cons (quote a) (quote ())))
+ '())
+(test-eval
+ '(car '(a))
+ 'a)
+(test-eval
+ '(cdr '(a))
+ '())
+(test-eval
+ '(car (cdr '(a b)))
+ 'b)
+(test-eval
+ '(car (car '((a b) c)))
+ 'a)
+(test-eval
+ '(car (cdr (car (cdr '((a c) (b d))))))
+ 'd)
+
+
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+
+
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(test-eval
+ '(car (cdr (add-lists '(1 2 3 4 5) '(2 3 4 5 6))))
+ 5)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+
+;; streams
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
blob - /dev/null
blob + 07eb30a0a383c1d47ed1e41f0fa500153cbc9469 (mode 644)
--- /dev/null
+++ ex4-33.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((quoted-pair? exp) (eval (quoted-pair->cons exp) env))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (and (tagged-list? exp 'quote)
+ (not (pair? (cadr exp)))))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+
+
+;; Exercise 4.33. Ben Bitdiddle tests the lazy list implementation given above by evaluating the expression
+
+(define (eval-quotation exp env)
+ (define (make-tree tree)
+ (if (pair? tree)
+ (eval
+ (make-cons (make-tree (car tree))
+ (make-tree (cdr tree)))
+ env)
+ tree))
+ (let ((qval (cadr exp)))
+ (make-tree qval)))
+
+(define (make-cons x y)
+ `(cons ,x ,y))
+
+
+;; (car '(a b c))
+
+;; (car (quote (a b c)))
+
+
+;; z = (thunk (quote (a b c)))
+
+;; if we have a quoted list, we need to transform it into the proper cons
+
+;; z = (cons a (cons b (cons c ())))
+
+;; (car '((a b) c))
+;; (car (quote ((a b) c)))
+
+;; z = (thunk (quote ((a b) c)))
+;; z = (cons (cons a (cons b ()))
+;; (cons c ()))
+
+;; To his surprise, this produces an error. After some thought, he realizes that the ``lists'' obtained by reading in quoted expressions are different from the lists manipulated by the new definitions of cons, car, and cdr. Modify the evaluator's treatment of quoted expressions so that quoted lists typed at the driver loop will produce true lazy lists.
+
+;; (quote (a))
+
+(test-eval
+ '(car '(a))
+ 'a)
+(test-eval
+ '(cdr '(a))
+ '())
+(test-eval
+ '(car (cdr '(a b)))
+ 'a)
+(test-eval
+ '(car (car '((a b) c)))
+ 'a)
+(test-eval
+ '(car (cdr (car (cdr '((a c) (b d))))))
+ 'd)
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+
+;; streams
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
blob - /dev/null
blob + ef4d33340f8ec7affd4585d72e38650b4b8016ad (mode 644)
--- /dev/null
+++ ex4-33.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp env))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+
+
+;; Exercise 4.33. Ben Bitdiddle tests the lazy list implementation given above by evaluating the expression
+
+(define (text-of-quotation exp env)
+ (define (make-tree tree)
+ (if (pair? tree)
+ (eval
+ (make-cons (make-tree (car tree))
+ (make-tree (cdr tree)))
+ env)
+ tree))
+ (let ((qval (cadr exp)))
+ (make-tree qval)))
+
+(define (make-cons x y)
+ `(cons ,x ,y))
+
+
+;; (car '(a b c))
+
+;; (car (quote (a b c)))
+
+
+;; z = (thunk (quote (a b c)))
+
+;; if we have a quoted list, we need to transform it into the proper cons
+
+;; z = (cons a (cons b (cons c ())))
+
+;; (car '((a b) c))
+;; (car (quote ((a b) c)))
+
+;; z = (thunk (quote ((a b) c)))
+;; z = (cons (cons a (cons b ()))
+;; (cons c ()))
+
+;; To his surprise, this produces an error. After some thought, he realizes that the ``lists'' obtained by reading in quoted expressions are different from the lists manipulated by the new definitions of cons, car, and cdr. Modify the evaluator's treatment of quoted expressions so that quoted lists typed at the driver loop will produce true lazy lists.
+
+;; (quote (a))
+
+(test-eval
+ '(car '(a))
+ 'a)
+(test-eval
+ '(cdr '(a))
+ '())
+(test-eval
+ '(car (cdr '(a b)))
+ 'a)
+(test-eval
+ '(car (car '((a b) c)))
+ 'a)
+(test-eval
+ '(car (cdr (car (cdr '((a c) (b d))))))
+ 'd)
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+
+;; streams
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
blob - /dev/null
blob + 143b034c60d552e9652198f9d9ea45186da20529 (mode 644)
--- /dev/null
+++ ex4-34-2.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((quoted-list? exp) (eval (list->cons (text-of-quotation exp)) env))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (and (tagged-list? exp 'quote)
+ (not (pair? (cadr exp)))))
+(define (text-of-quotation exp) (cadr exp))
+(define (quoted-list? exp)
+ (and (tagged-list? exp 'quote)
+ (pair? (cadr exp))))
+(define (list->cons exp)
+ (if (pair? exp)
+ (make-cons (list->cons (car exp))
+ (list->cons (cdr exp)))
+ (make-quote exp)))
+(define (make-quote exp)
+ `(quote ,exp))
+(define (make-cons x y)
+ `(cons ,x ,y))
+
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (if (eq? (lookup-variable-value 'cons the-global-environment)
+ object)
+ (display 'cons)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>)))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+
+
+
+
+;; Exercise 4.34. Modify the driver loop for the evaluator so that lazy pairs and lists will print in some reasonable way. (What are you going to do about infinite lists?) You may also need to modify the representation of lazy pairs so that the evaluator can identify them in order to print them.
+
+
+(test-eval
+ '(car (cons (quote a) (quote ())))
+ 'a)
+(test-eval
+ '(cdr (cons (quote a) (quote ())))
+ '())
+(test-eval
+ '(car '(a))
+ 'a)
+(test-eval
+ '(cdr '(a))
+ '())
+(test-eval
+ '(car (cdr '(a b)))
+ 'b)
+(test-eval
+ '(car (car '((a b) c)))
+ 'a)
+(test-eval
+ '(car (cdr (car (cdr '((a c) (b d))))))
+ 'd)
+
+
+
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(test-eval
+ '(car (cdr (add-lists '(1 2 3 4 5) '(2 3 4 5 6))))
+ 5)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+
+;; streams
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
blob - /dev/null
blob + a7d55cf30543fbb2c2c7223d61aa89382f4aa8dc (mode 644)
--- /dev/null
+++ ex4-34-2.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((quoted-list? exp) (eval (list->cons (text-of-quotation exp)) env))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (and (tagged-list? exp 'quote)
+ (not (pair? (cadr exp)))))
+(define (text-of-quotation exp) (cadr exp))
+(define (quoted-list? exp)
+ (and (tagged-list? exp 'quote)
+ (pair? (cadr exp))))
+(define (list->cons exp)
+ (if (pair? exp)
+ (make-cons (list->cons (car exp))
+ (list->cons (cdr exp)))
+ (make-quote exp)))
+(define (make-quote exp)
+ `(quote ,exp))
+(define (make-cons x y)
+ `(cons ,x ,y))
+
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+
+
+
+
+;; Exercise 4.34. Modify the driver loop for the evaluator so that lazy pairs and lists will print in some reasonable way. (What are you going to do about infinite lists?) You may also need to modify the representation of lazy pairs so that the evaluator can identify them in order to print them.
+
+
+(test-eval
+ '(car (cons (quote a) (quote ())))
+ 'a)
+(test-eval
+ '(cdr (cons (quote a) (quote ())))
+ '())
+(test-eval
+ '(car '(a))
+ 'a)
+(test-eval
+ '(cdr '(a))
+ '())
+(test-eval
+ '(car (cdr '(a b)))
+ 'b)
+(test-eval
+ '(car (car '((a b) c)))
+ 'a)
+(test-eval
+ '(car (cdr (car (cdr '((a c) (b d))))))
+ 'd)
+
+
+
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(test-eval
+ '(car (cdr (add-lists '(1 2 3 4 5) '(2 3 4 5 6))))
+ 5)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+
+;; streams
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
blob - /dev/null
blob + a7d55cf30543fbb2c2c7223d61aa89382f4aa8dc (mode 644)
--- /dev/null
+++ ex4-34.scm
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((quoted-list? exp) (eval (list->cons (text-of-quotation exp)) env))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (and (tagged-list? exp 'quote)
+ (not (pair? (cadr exp)))))
+(define (text-of-quotation exp) (cadr exp))
+(define (quoted-list? exp)
+ (and (tagged-list? exp 'quote)
+ (pair? (cadr exp))))
+(define (list->cons exp)
+ (if (pair? exp)
+ (make-cons (list->cons (car exp))
+ (list->cons (cdr exp)))
+ (make-quote exp)))
+(define (make-quote exp)
+ `(quote ,exp))
+(define (make-cons x y)
+ `(cons ,x ,y))
+
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+
+
+
+
+;; Exercise 4.34. Modify the driver loop for the evaluator so that lazy pairs and lists will print in some reasonable way. (What are you going to do about infinite lists?) You may also need to modify the representation of lazy pairs so that the evaluator can identify them in order to print them.
+
+
+(test-eval
+ '(car (cons (quote a) (quote ())))
+ 'a)
+(test-eval
+ '(cdr (cons (quote a) (quote ())))
+ '())
+(test-eval
+ '(car '(a))
+ 'a)
+(test-eval
+ '(cdr '(a))
+ '())
+(test-eval
+ '(car (cdr '(a b)))
+ 'b)
+(test-eval
+ '(car (car '((a b) c)))
+ 'a)
+(test-eval
+ '(car (cdr (car (cdr '((a c) (b d))))))
+ 'd)
+
+
+
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(test-eval
+ '(car (cdr (add-lists '(1 2 3 4 5) '(2 3 4 5 6))))
+ 5)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+
+;; streams
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
blob - /dev/null
blob + 2ab93c78e0debd5818ba5ea4b8de5efae2d11879 (mode 644)
--- /dev/null
+++ ex4-34.scm~
+;; (define apply-in-underlying-scheme apply)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((quoted-list? exp) (eval (list->cons (text-of-quotation exp)) env))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+;; ((unbound? exp) (eval-unbound exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((letrec? exp) (eval (letrec->let exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (actual-value (operator exp) env)
+ (operands exp)
+ env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments env)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ (list-of-arg-values arguments env)))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ (list-of-delayed-args arguments env)
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (thunk? obj)
+ (tagged-list? obj 'thunk))
+(define (thunk-exp thunk)
+ (cadr thunk))
+(define (thunk-env thunk)
+ (caddr thunk))
+(define (evaluated-thunk? obj)
+ (tagged-list? obj 'evaluated-thunk))
+(define (thunk-value evaluated-thunk)
+ (cadr evaluated-thunk))
+(define (delay-it exp env)
+ `(thunk ,exp ,env))
+(define (actual-value exp env)
+ (force-it (eval exp env)))
+(define (force-it obj)
+ (cond ((thunk? obj)
+ (let ((result (actual-value
+ (thunk-exp obj)
+ (thunk-env obj))))
+ (set-car! obj 'evaluated-thunk)
+ (set-car! (cdr obj) result)
+ (set-cdr! (cdr obj) '())
+ result))
+ ((evaluated-thunk? obj)
+ (thunk-value obj))
+ (else obj)))
+
+(define (list-of-arg-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (actual-value (first-operand exps) env)
+ (list-of-arg-values (rest-operands exps) env))))
+(define (list-of-delayed-args exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (delay-it (first-operand exps) env)
+ (list-of-delayed-args (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (and (tagged-list? exp 'quote)
+ (not (pair? (cadr exp)))))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; make-unbound!
+
+;; (define (unbound? exp)
+;; (tagged-list? exp 'make-unbound!))
+;; (define (unbound-var exp)
+;; (cadr exp))
+;; (define (eval-unbound exp env)
+;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
+
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (actual-value (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+
+
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (make-application op args)
+ (cons op args))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+;; (define (scan-out-defines body)
+;; (let* ((definitions (filter definition? body))
+;; (vars (map definition-variable definitions))
+;; (unassigneds (map (lambda (var) ''*unassigned*)
+;; vars))
+;; (vals (map definition-value definitions))
+;; (assignments
+;; (map (lambda (var val)
+;; (make-assignment var val))
+;; vars vals))
+;; (exps (remove definition? body)))
+;; (if (null? definitions)
+;; body
+;; (list
+;; (make-let vars
+;; unassigneds
+;; (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+(define (remove-binding-from-frame! var frame)
+ (define (scan vars vals)
+ (cond ((null? (cdr vars))
+ (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+ ((eq? var (cadr vars))
+ (set-cdr! vars (cddr vars))
+ (set-cdr! vals (cddr vals)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (let ((vars (frame-variables frame))
+ (vals (frame-values frame)))
+ (if (eq? var (car vars))
+ (begin (set-car! frame (cdr vars))
+ (set-cdr! frame (cdr vals)))
+ (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (actual-value input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (force-it (geval exp)) expected))
+
+;; Exercise 4.33. Ben Bitdiddle tests the lazy list implementation given above by evaluating the expression
+
+(define (quoted-list? exp)
+ (and (tagged-list? exp 'quote)
+ (pair? (cadr exp))))
+
+(define (list->cons exp)
+ (if (pair? exp)
+ (make-cons (list->cons (car exp))
+ (list->cons (cdr exp)))
+ (make-quote exp)))
+(define (make-quote exp)
+ `(quote ,exp))
+(define (make-cons x y)
+ `(cons ,x ,y))
+
+;; (car '(a b c))
+
+;; if we have a quoted list, we need to transform it into the proper cons
+
+;; To his surprise, this produces an error. After some thought, he realizes that the ``lists'' obtained by reading in quoted expressions are different from the lists manipulated by the new definitions of cons, car, and cdr. Modify the evaluator's treatment of quoted expressions so that quoted lists typed at the driver loop will produce true lazy lists.
+
+;; (quote (a))
+(test-eval
+ '(car (cons (quote a) (quote ())))
+ 'a)
+(test-eval
+ '(cdr (cons (quote a) (quote ())))
+ '())
+(test-eval
+ '(car '(a))
+ 'a)
+(test-eval
+ '(cdr '(a))
+ '())
+(test-eval
+ '(car (cdr '(a b)))
+ 'b)
+(test-eval
+ '(car (car '((a b) c)))
+ 'a)
+(test-eval
+ '(car (cdr (car (cdr '((a c) (b d))))))
+ 'd)
+
+
+
+;; cons/car/cdr
+
+(geval
+ '(define (cons x y)
+ (lambda (m) (m x y))))
+(geval
+ '(define (car z)
+ (z (lambda (p q) p))))
+(geval
+ '(define (cdr z)
+ (z (lambda (p q) q))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (map proc items)
+ (if (null? items)
+ '()
+ (cons (proc (car items))
+ (map proc (cdr items))))))
+(geval
+ '(define (scale-list items factor)
+ (map (lambda (x) (* x factor))
+ items)))
+(geval
+ '(define (add-lists list1 list2)
+ (cond ((null? list1) list2)
+ ((null? list2) list1)
+ (else (cons (+ (car list1) (car list2))
+ (add-lists (cdr list1) (cdr list2)))))))
+
+
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(test-eval
+ '(car (cdr (add-lists '(1 2 3 4 5) '(2 3 4 5 6))))
+ 5)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+
+;; delayed-evaluation
+
+(geval
+ '(define (try a b)
+ (if (= a 0) 1 b)))
+(test-eval '(try 0 (/ 1 0)) 1)
+
+(geval
+ '(define (unless condition usual-value exceptional-value)
+ (if condition exceptional-value usual-value)))
+(test-eval
+ '(let ((a 4) (b 0))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 0)
+(test-eval
+ '(let ((a 4) (b 2))
+ (unless (= b 0)
+ (/ a b)
+ (begin (display "exception: returning 0")
+ 0)))
+ 2)
+
+(geval
+ '(define (factorial n)
+ (unless (= n 1)
+ (* n (factorial (- n 1)))
+ 1)))
+(test-eval
+ '(factorial 8)
+ 40320)
+
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+
+(geval '(define w (id (id 10))))
+(test-eval 'count 1)
+(test-eval 'w 10)
+(test-eval 'count 2)
+(test-eval
+ '(let ((f (lambda (x) (+ x 1))))
+ (f 1))
+ 2)
+(geval '(define count 0))
+(geval '(define (id x)
+ (set! count (+ count 1))
+ x))
+(geval
+ '(define (square x)
+ (* x x)))
+(test-eval
+ '(square (id 10))
+ 100)
+(test-eval 'count 1)
+;; would be 2 without memoization
+
+
+;; streams
+
+(geval
+ '(define ones (cons 1 ones)))
+(geval
+ '(define integers (cons 1 (add-lists ones integers))))
+(test-eval
+ '(list-ref integers 17)
+ 18)
+
+(geval
+ '(define (integral integrand initial-value dt)
+ (define int
+ (cons initial-value
+ (add-lists (scale-list integrand dt)
+ int)))
+ int))
+(geval
+ '(define (solve f y0 dt)
+ (define y (integral dy y0 dt))
+ (define dy (map f y))
+ y))
+(test-eval
+ '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
+ 2.716924)
blob - /dev/null
blob + a13e2b9bb546d5c9c88564301836d2b443445b58 (mode 644)
--- /dev/null
+++ ex4-35.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+;; Exercise 4.35. Write a procedure an-integer-between that returns an integer between two given bounds. This can be used to implement a procedure that finds Pythagorean triples, i.e., triples of integers (i,j,k) between the given bounds such that i < j and i2 + j2 = k2, as follows:
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+(test-eval
+ '(a-pythagorean-triple-between 1 20)
+ '(3 4 5))
+(test-eval 'try-again '(5 12 13))
+(test-eval 'try-again '(6 8 10))
+(test-eval 'try-again '(8 15 17))
+(test-eval 'try-again '(9 12 15))
blob - /dev/null
blob + 9ae4b3f628762ae603ea736d7e0e8004b3433c54 (mode 644)
--- /dev/null
+++ ex4-35.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+
+
+
blob - /dev/null
blob + 1840b156b2ed9db5c1766da35ab6b0419e0afe39 (mode 644)
--- /dev/null
+++ ex4-36.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+;; Exercise 4.36. Exercise 3.69 discussed how to generate the stream of all Pythagorean triples, with no upper bound on the size of the integers to be searched. Explain why simply replacing an-integer-between by an-integer-starting-from in the procedure in exercise 4.35 is not an adequate way to generate arbitrary Pythagorean triples. Write a procedure that actually will accomplish this. (That is, write a procedure for which repeatedly typing try-again would in principle eventually generate all Pythagorean triples.)
+
+;; the problem is that this definition:
+
+;; (define (pythagorean-triples-starting-from low)
+;; (let ((i (an-integer-starting-from low))
+;; (j (an-integer-starting-from i))
+;; (k (an-integer-starting-from j)))
+;; (require (= (+ (* i i) (* j j)) (* k k)))
+;; (list i j k)))
+
+;; calling try-again would change k but not i or j, and k has an infinite number of possibilities which could be tested
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+(test-eval '(pythagorean-triples-starting-from 1)
+ '(3 4 5))
+(test-eval 'try-again '(6 8 10))
+(test-eval 'try-again '(5 12 13))
+(test-eval 'try-again '(9 12 15))
+(test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+
+(test-eval '(pythagorean-triples-starting-from 1)
+ '(3 4 5))
+(test-eval 'try-again '(6 8 10))
+(test-eval 'try-again '(5 12 13))
+(test-eval 'try-again '(9 12 15))
+(test-eval 'try-again '(8 15 17))
blob - /dev/null
blob + a13e2b9bb546d5c9c88564301836d2b443445b58 (mode 644)
--- /dev/null
+++ ex4-36.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+;; Exercise 4.35. Write a procedure an-integer-between that returns an integer between two given bounds. This can be used to implement a procedure that finds Pythagorean triples, i.e., triples of integers (i,j,k) between the given bounds such that i < j and i2 + j2 = k2, as follows:
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+(test-eval
+ '(a-pythagorean-triple-between 1 20)
+ '(3 4 5))
+(test-eval 'try-again '(5 12 13))
+(test-eval 'try-again '(6 8 10))
+(test-eval 'try-again '(8 15 17))
+(test-eval 'try-again '(9 12 15))
blob - /dev/null
blob + 5d8e8442e12f484ae1272519e28108f584fd5cc7 (mode 644)
--- /dev/null
+++ ex4-37.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+;; (geval
+;; '(define (multiple-dwelling)
+;; (let ((baker (amb 1 2 3 4 5))
+;; (cooper (amb 1 2 3 4 5))
+;; (fletcher (amb 1 2 3 4 5))
+;; (miller (amb 1 2 3 4 5))
+;; (smith (amb 1 2 3 4 5)))
+;; (require
+;; (distinct? (list baker cooper fletcher miller smith)))
+;; (require (not (= baker 5)))
+;; (require (not (= cooper 1)))
+;; (require (not (= fletcher 5)))
+;; (require (not (= fletcher 1)))
+;; (require (> miller cooper))
+;; (require (not (= (abs (- smith fletcher)) 1)))
+;; (require (not (= (abs (- fletcher cooper)) 1)))
+;; (list (list 'baker baker)
+;; (list 'cooper cooper)
+;; (list 'fletcher fletcher)
+;; (list 'miller miller)
+;; (list 'smith smith)))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+;; (test-eval '(multiple-dwelling)
+;; '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+
+;; Exercise 4.38. Modify the multiple-dwelling procedure to omit the requirement that Smith and Fletcher do not live on adjacent floors. How many solutions are there to this modified puzzle?
+
+(geval
+ '(define (multiple-dwelling)
+ (let ((baker (amb 1 2 3 4 5))
+ (cooper (amb 1 2 3 4 5))
+ (fletcher (amb 1 2 3 4 5))
+ (miller (amb 1 2 3 4 5))
+ (smith (amb 1 2 3 4 5)))
+ (require
+ (distinct? (list baker cooper fletcher miller smith)))
+ (require (not (= baker 5)))
+ (require (not (= cooper 1)))
+ (require (not (= fletcher 5)))
+ (require (not (= fletcher 1)))
+ (require (> miller cooper))
+ (require (not (= (abs (- fletcher cooper)) 1)))
+ (list (list 'baker baker)
+ (list 'cooper cooper)
+ (list 'fletcher fletcher)
+ (list 'miller miller)
+ (list 'smith smith)))))
+
+(user-print (geval '(multiple-dwelling)))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+
+;; 5 total solutions
blob - /dev/null
blob + 1840b156b2ed9db5c1766da35ab6b0419e0afe39 (mode 644)
--- /dev/null
+++ ex4-37.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+;; Exercise 4.36. Exercise 3.69 discussed how to generate the stream of all Pythagorean triples, with no upper bound on the size of the integers to be searched. Explain why simply replacing an-integer-between by an-integer-starting-from in the procedure in exercise 4.35 is not an adequate way to generate arbitrary Pythagorean triples. Write a procedure that actually will accomplish this. (That is, write a procedure for which repeatedly typing try-again would in principle eventually generate all Pythagorean triples.)
+
+;; the problem is that this definition:
+
+;; (define (pythagorean-triples-starting-from low)
+;; (let ((i (an-integer-starting-from low))
+;; (j (an-integer-starting-from i))
+;; (k (an-integer-starting-from j)))
+;; (require (= (+ (* i i) (* j j)) (* k k)))
+;; (list i j k)))
+
+;; calling try-again would change k but not i or j, and k has an infinite number of possibilities which could be tested
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+(test-eval '(pythagorean-triples-starting-from 1)
+ '(3 4 5))
+(test-eval 'try-again '(6 8 10))
+(test-eval 'try-again '(5 12 13))
+(test-eval 'try-again '(9 12 15))
+(test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+
+(test-eval '(pythagorean-triples-starting-from 1)
+ '(3 4 5))
+(test-eval 'try-again '(6 8 10))
+(test-eval 'try-again '(5 12 13))
+(test-eval 'try-again '(9 12 15))
+(test-eval 'try-again '(8 15 17))
blob - /dev/null
blob + 3e1897d9ec29072d302b357ea06e1191cdd42246 (mode 644)
--- /dev/null
+++ ex4-38.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+;; (geval
+;; '(define (multiple-dwelling)
+;; (let ((baker (amb 1 2 3 4 5))
+;; (cooper (amb 1 2 3 4 5))
+;; (fletcher (amb 1 2 3 4 5))
+;; (miller (amb 1 2 3 4 5))
+;; (smith (amb 1 2 3 4 5)))
+;; (require
+;; (distinct? (list baker cooper fletcher miller smith)))
+;; (require (not (= baker 5)))
+;; (require (not (= cooper 1)))
+;; (require (not (= fletcher 5)))
+;; (require (not (= fletcher 1)))
+;; (require (> miller cooper))
+;; (require (not (= (abs (- smith fletcher)) 1)))
+;; (require (not (= (abs (- fletcher cooper)) 1)))
+;; (list (list 'baker baker)
+;; (list 'cooper cooper)
+;; (list 'fletcher fletcher)
+;; (list 'miller miller)
+;; (list 'smith smith)))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+;; (test-eval '(multiple-dwelling)
+;; '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+
+;; Exercise 4.38. Modify the multiple-dwelling procedure to omit the requirement that Smith and Fletcher do not live on adjacent floors. How many solutions are there to this modified puzzle?
+
+(geval
+ '(define (multiple-dwelling)
+ (let ((baker (amb 1 2 3 4 5))
+ (cooper (amb 1 2 3 4 5))
+ (fletcher (amb 1 2 3 4 5))
+ (miller (amb 1 2 3 4 5))
+ (smith (amb 1 2 3 4 5)))
+ (require
+ (distinct? (list baker cooper fletcher miller smith)))
+ (require (not (= baker 5)))
+ (require (not (= cooper 1)))
+ (require (not (= fletcher 5)))
+ (require (not (= fletcher 1)))
+ (require (> miller cooper))
+ (require (not (= (abs (- fletcher cooper)) 1)))
+ (list (list 'baker baker)
+ (list 'cooper cooper)
+ (list 'fletcher fletcher)
+ (list 'miller miller)
+ (list 'smith smith)))))
+
+(user-print (geval '(multiple-dwelling)))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+
+;; 5 total solutions
+;; 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.
blob - /dev/null
blob + 5d8e8442e12f484ae1272519e28108f584fd5cc7 (mode 644)
--- /dev/null
+++ ex4-38.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+;; (geval
+;; '(define (multiple-dwelling)
+;; (let ((baker (amb 1 2 3 4 5))
+;; (cooper (amb 1 2 3 4 5))
+;; (fletcher (amb 1 2 3 4 5))
+;; (miller (amb 1 2 3 4 5))
+;; (smith (amb 1 2 3 4 5)))
+;; (require
+;; (distinct? (list baker cooper fletcher miller smith)))
+;; (require (not (= baker 5)))
+;; (require (not (= cooper 1)))
+;; (require (not (= fletcher 5)))
+;; (require (not (= fletcher 1)))
+;; (require (> miller cooper))
+;; (require (not (= (abs (- smith fletcher)) 1)))
+;; (require (not (= (abs (- fletcher cooper)) 1)))
+;; (list (list 'baker baker)
+;; (list 'cooper cooper)
+;; (list 'fletcher fletcher)
+;; (list 'miller miller)
+;; (list 'smith smith)))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+;; (test-eval '(multiple-dwelling)
+;; '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+
+;; Exercise 4.38. Modify the multiple-dwelling procedure to omit the requirement that Smith and Fletcher do not live on adjacent floors. How many solutions are there to this modified puzzle?
+
+(geval
+ '(define (multiple-dwelling)
+ (let ((baker (amb 1 2 3 4 5))
+ (cooper (amb 1 2 3 4 5))
+ (fletcher (amb 1 2 3 4 5))
+ (miller (amb 1 2 3 4 5))
+ (smith (amb 1 2 3 4 5)))
+ (require
+ (distinct? (list baker cooper fletcher miller smith)))
+ (require (not (= baker 5)))
+ (require (not (= cooper 1)))
+ (require (not (= fletcher 5)))
+ (require (not (= fletcher 1)))
+ (require (> miller cooper))
+ (require (not (= (abs (- fletcher cooper)) 1)))
+ (list (list 'baker baker)
+ (list 'cooper cooper)
+ (list 'fletcher fletcher)
+ (list 'miller miller)
+ (list 'smith smith)))))
+
+(user-print (geval '(multiple-dwelling)))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+
+;; 5 total solutions
blob - /dev/null
blob + 995ec71cbfb390b5d73f90a5109c517f05d5f2de (mode 644)
--- /dev/null
+++ ex4-39.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+;; (geval
+;; '(define (multiple-dwelling)
+;; (let ((baker (amb 1 2 3 4 5))
+;; (cooper (amb 1 2 3 4 5))
+;; (fletcher (amb 1 2 3 4 5))
+;; (miller (amb 1 2 3 4 5))
+;; (smith (amb 1 2 3 4 5)))
+;; (require
+;; (distinct? (list baker cooper fletcher miller smith)))
+;; (require (not (= baker 5)))
+;; (require (not (= cooper 1)))
+;; (require (not (= fletcher 5)))
+;; (require (not (= fletcher 1)))
+;; (require (> miller cooper))
+;; (require (not (= (abs (- smith fletcher)) 1)))
+;; (require (not (= (abs (- fletcher cooper)) 1)))
+;; (list (list 'baker baker)
+;; (list 'cooper cooper)
+;; (list 'fletcher fletcher)
+;; (list 'miller miller)
+;; (list 'smith smith)))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+;; (test-eval '(multiple-dwelling)
+;; '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+;; 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.
+
+;; the order doesn't matter as for correctness, but it does affect speed
+;; require is slow because it must, for each element, check through all the remaining elements
+
+(geval
+ '(define (multiple-dwelling)
+ (let ((baker (amb 1 2 3 4 5))
+ (cooper (amb 1 2 3 4 5))
+ (fletcher (amb 1 2 3 4 5))
+ (miller (amb 1 2 3 4 5))
+ (smith (amb 1 2 3 4 5)))
+ (require (> miller cooper))
+ (require (not (= baker 5)))
+ (require (not (= cooper 1)))
+ (require (not (= fletcher 5)))
+ (require (not (= fletcher 1)))
+ (require (not (= (abs (- smith fletcher)) 1)))
+ (require (not (= (abs (- fletcher cooper)) 1)))
+ (require
+ (distinct? (list baker cooper fletcher miller smith)))
+ (list (list 'baker baker)
+ (list 'cooper cooper)
+ (list 'fletcher fletcher)
+ (list 'miller miller)
+ (list 'smith smith)))))
+
+;; this is going to be significantly faster
blob - /dev/null
blob + 3e1897d9ec29072d302b357ea06e1191cdd42246 (mode 644)
--- /dev/null
+++ ex4-39.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+;; (geval
+;; '(define (multiple-dwelling)
+;; (let ((baker (amb 1 2 3 4 5))
+;; (cooper (amb 1 2 3 4 5))
+;; (fletcher (amb 1 2 3 4 5))
+;; (miller (amb 1 2 3 4 5))
+;; (smith (amb 1 2 3 4 5)))
+;; (require
+;; (distinct? (list baker cooper fletcher miller smith)))
+;; (require (not (= baker 5)))
+;; (require (not (= cooper 1)))
+;; (require (not (= fletcher 5)))
+;; (require (not (= fletcher 1)))
+;; (require (> miller cooper))
+;; (require (not (= (abs (- smith fletcher)) 1)))
+;; (require (not (= (abs (- fletcher cooper)) 1)))
+;; (list (list 'baker baker)
+;; (list 'cooper cooper)
+;; (list 'fletcher fletcher)
+;; (list 'miller miller)
+;; (list 'smith smith)))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+;; (test-eval '(multiple-dwelling)
+;; '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+
+;; Exercise 4.38. Modify the multiple-dwelling procedure to omit the requirement that Smith and Fletcher do not live on adjacent floors. How many solutions are there to this modified puzzle?
+
+(geval
+ '(define (multiple-dwelling)
+ (let ((baker (amb 1 2 3 4 5))
+ (cooper (amb 1 2 3 4 5))
+ (fletcher (amb 1 2 3 4 5))
+ (miller (amb 1 2 3 4 5))
+ (smith (amb 1 2 3 4 5)))
+ (require
+ (distinct? (list baker cooper fletcher miller smith)))
+ (require (not (= baker 5)))
+ (require (not (= cooper 1)))
+ (require (not (= fletcher 5)))
+ (require (not (= fletcher 1)))
+ (require (> miller cooper))
+ (require (not (= (abs (- fletcher cooper)) 1)))
+ (list (list 'baker baker)
+ (list 'cooper cooper)
+ (list 'fletcher fletcher)
+ (list 'miller miller)
+ (list 'smith smith)))))
+
+(user-print (geval '(multiple-dwelling)))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+(user-print (geval 'try-again))
+(newline)
+
+;; 5 total solutions
+;; 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.
blob - /dev/null
blob + 56b46a003124e39baa692fb4e5b8e547c0dc804c (mode 644)
--- /dev/null
+++ ex4-4-2.scm
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; Exercise 4.4. Recall the definitions of the special forms and and or from chapter 1:
+
+;; and: The expressions are evaluated from left to right. If any expression evaluates to false, false is returned; any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then true is returned.
+
+;; or: The expressions are evaluated from left to right. If any expression evaluates to a true value, that value is returned; any remaining expressions are not evaluated. If all expressions evaluate to false, or if there are no expressions, then false is returned.
+
+;; Install and and or as new special forms for the evaluator by defining appropriate syntax procedures and evaluation procedures eval-and and eval-or. Alternatively, show how to implement and and or as derived expressions.
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+;; (define (and->if exp)
+;; (define (expand-clauses clauses)
+;; (cond ((null? clauses) 'true)
+;; ((null? (cdr clauses)) (car clauses))
+;; (else (make-if (car clauses)
+;; (expand-clauses (cdr clauses))
+;; 'false))))
+;; (expand-clauses (and-clauses exp)))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+;; the problem with this definition is that each clause will be evaluated twice; this is unacceptable if there are side effects
+;; (define (or->if exp)
+;; (define (expand-clauses clauses)
+;; (if (null? clauses)
+;; 'false
+;; (make-if (car clauses)
+;; (car clauses)
+;; (expand-clauses (cdr clauses)))))
+;; (expand-clauses (or-clauses exp)))
+
+
+;; we can also install and/or as special forms
+
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+;; test-suite
+
+;; make-let
+(test-case (geval (make-let '(x y) '(3 5) '((+ x y))))
+ 8)
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-case (geval '(and 0 true x)) 11)
+(test-case (geval '(and 0 true x false)) false)
+(test-case (geval '(and 0 true x (set! x -2) false)) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(and 0 true x false (set! x -5))) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(or false (set! x 25))) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or (set! x 2) (set! x 4))) 'ok)
+(test-case (geval 'x) 2)
+(test-case (geval '(or false (set! x 25) true false)) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or ((lambda (x) x) 5))) 5)
+(test-case (geval '(or (begin (set! x (+ x 1)) x))) 26)
+
+
+;; all special forms
+(test-case (geval '(begin 5 6)) 6)
+(test-case (geval '10) 10)
+(geval '(define x 3))
+(test-case (geval 'x) 3)
+(test-case (geval '(set! x -25)) 'ok)
+(test-case (geval 'x) -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-case (geval '(z 3 4)) 15)
+(test-case (geval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-case (geval '(if true false true)) false)
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-case (geval '(factorial 5)) 120)
+
+
blob - /dev/null
blob + 87c39241329b6d550509d38f60293acc9a5f64e3 (mode 644)
--- /dev/null
+++ ex4-4-2.scm~
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; Exercise 4.4. Recall the definitions of the special forms and and or from chapter 1:
+
+;; and: The expressions are evaluated from left to right. If any expression evaluates to false, false is returned; any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then true is returned.
+
+;; or: The expressions are evaluated from left to right. If any expression evaluates to a true value, that value is returned; any remaining expressions are not evaluated. If all expressions evaluate to false, or if there are no expressions, then false is returned.
+
+;; Install and and or as new special forms for the evaluator by defining appropriate syntax procedures and evaluation procedures eval-and and eval-or. Alternatively, show how to implement and and or as derived expressions.
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+;; (define (and->if exp)
+;; (define (expand-clauses clauses)
+;; (cond ((null? clauses) 'true)
+;; ((null? (cdr clauses)) (car clauses))
+;; (else (make-if (car clauses)
+;; (expand-clauses (cdr clauses))
+;; 'false))))
+;; (expand-clauses (and-clauses exp)))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+;; the problem with this definition is that each clause will be evaluated twice; this is unacceptable if there are side effects
+;; (define (or->if exp)
+;; (define (expand-clauses clauses)
+;; (if (null? clauses)
+;; 'false
+;; (make-if (car clauses)
+;; (car clauses)
+;; (expand-clauses (cdr clauses)))))
+;; (expand-clauses (or-clauses exp)))
+
+
+;; we can also install and/or as special forms
+
+(define (eval-and exp env)
+ ...)
+(define (eval-or exp env)
+ ...)
+
+;; test-suite
+
+;; make-let
+(test-case (geval (make-let '(x y) '(3 5) '((+ x y))))
+ 8)
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-case (geval '(and 0 true x)) 11)
+(test-case (geval '(and 0 true x false)) false)
+(test-case (geval '(and 0 true x (set! x -2) false)) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(and 0 true x false (set! x -5))) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(or false (set! x 25))) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or (set! x 2) (set! x 4))) 'ok)
+(test-case (geval 'x) 2)
+(test-case (geval '(or false (set! x 25) true false)) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or ((lambda (x) x) 5))) 5)
+(test-case (geval '(or (begin (set! x (+ x 1)) x))) 26)
+
+
+;; all special forms
+(test-case (geval '(begin 5 6)) 6)
+(test-case (geval '10) 10)
+(geval '(define x 3))
+(test-case (geval 'x) 3)
+(test-case (geval '(set! x -25)) 'ok)
+(test-case (geval 'x) -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-case (geval '(z 3 4)) 15)
+(test-case (geval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-case (geval '(if true false true)) false)
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-case (geval '(factorial 5)) 120)
+
+
blob - /dev/null
blob + b668827cc615d6f1c1707c8493716828599031dd (mode 644)
--- /dev/null
+++ ex4-4.scm
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval (and->if exp) env))
+ ((or? exp) (eval (or->if exp) env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; Exercise 4.4. Recall the definitions of the special forms and and or from chapter 1:
+
+;; and: The expressions are evaluated from left to right. If any expression evaluates to false, false is returned; any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then true is returned.
+
+;; or: The expressions are evaluated from left to right. If any expression evaluates to a true value, that value is returned; any remaining expressions are not evaluated. If all expressions evaluate to false, or if there are no expressions, then false is returned.
+
+;; Install and and or as new special forms for the evaluator by defining appropriate syntax procedures and evaluation procedures eval-and and eval-or. Alternatively, show how to implement and and or as derived expressions.
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+;; the problem with this definition is that each clause will be evaluated twice; this is unacceptable if there are side effects
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+
+;; test-suite
+
+;; make-let
+(test-case (geval (make-let '(x y) '(3 5) '((+ x y))))
+ 8)
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-case (geval '(and 0 true x)) 11)
+(test-case (geval '(and 0 true x false)) false)
+(test-case (geval '(and 0 true x (set! x -2) false)) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(and 0 true x false (set! x -5))) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(or false (set! x 25))) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or (set! x 2) (set! x 4))) 'ok)
+(test-case (geval 'x) 2)
+(test-case (geval '(or false (set! x 25) true false)) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or ((lambda (x) x) 5))) 5)
+(test-case (geval '(or (begin (set! x (+ x 1)) x))) 27) ;; this should be 26 but it will show as 27 because of the poor way in which or->if is implemented
+
+
+;; (let ((first-clause <first-clause>))
+;; (make-if first-clause
+;; first-clause
+;; ...
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+
+
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-let
+ (list 'gensym) ;; not sure how to generate unique symbols in scheme
+ (list (car clauses))
+ (list (make-if 'gensym
+ 'gensym
+ (expand-clauses (cdr clauses)))))))
+ (expand-clauses (or-clauses exp)))
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-case (geval '(and 0 true x)) 11)
+(test-case (geval '(and 0 true x false)) false)
+(test-case (geval '(and 0 true x (set! x -2) false)) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(and 0 true x false (set! x -5))) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(or false (set! x 25))) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or (set! x 2) (set! x 4))) 'ok)
+(test-case (geval 'x) 2)
+(test-case (geval '(or false (set! x 25) true false)) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or ((lambda (x) x) 5))) 5)
+(test-case (geval '(or (begin (set! x (+ x 1)) x))) 26) ;; this works until code actually uses the symbol gensym...
+
+
+;; all special forms
+(test-case (geval '(begin 5 6)) 6)
+(test-case (geval '10) 10)
+(geval '(define x 3))
+(test-case (geval 'x) 3)
+(test-case (geval '(set! x -25)) 'ok)
+(test-case (geval 'x) -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-case (geval '(z 3 4)) 15)
+(test-case (geval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-case (geval '(if true false true)) false)
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-case (geval '(factorial 5)) 120)
+
+
blob - /dev/null
blob + 5682ce15867bc4883ab31e29b81ec47ad97ad5dc (mode 644)
--- /dev/null
+++ ex4-4.scm~
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+
+(define (make-table)
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; Exercise 4.3. Rewrite eval so that the dispatch is done in data-directed style. Compare this with the data-directed differentiation procedure of exercise 2.73. (You may use the car of a compound expression as the type of the expression, as is appropriate for the syntax implemented in this section.
+
+(define (form? exp)
+ (pair? exp))
+(define (form-type exp)
+ (car exp))
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((and (form? exp)
+ (get (form-type exp) 'eval))
+ ((get (form-type exp) 'eval) exp env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp env) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(put 'quote 'eval text-of-quotation)
+(put 'set! 'eval eval-assignment)
+(put 'define 'eval eval-definition)
+(put 'if 'eval eval-if)
+(put 'lambda
+ 'eval
+ (lambda (exp env)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env)))
+(put 'begin
+ 'eval
+ (lambda (exp env)
+ (eval-sequence (begin-actions exp) env)))
+(put 'cond
+ 'eval
+ (lambda (exp env)
+ (eval (cond->if exp) env)))
+(put 'let
+ 'eval
+ (lambda (exp env)
+ (eval (let->combination exp) env)))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; test-suite
+
+(test-case (geval '(begin 5 6)) 6)
+(test-case (geval '10) 10)
+(geval '(define x 3))
+(test-case (geval 'x) 3)
+(test-case (geval '(set! x -25)) 'ok)
+(test-case (geval 'x) -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-case (geval '(z 3 4)) 15)
+(test-case (geval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-case (geval '(if true false true)) false)
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+
+
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-case (geval '(factorial 5)) 120)
+
+
blob - /dev/null
blob + dc505ed7635b0b1e73cc735cb251752c5a306c33 (mode 644)
--- /dev/null
+++ ex4-40.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+;; (geval
+;; '(define (multiple-dwelling)
+;; (let ((baker (amb 1 2 3 4 5))
+;; (cooper (amb 1 2 3 4 5))
+;; (fletcher (amb 1 2 3 4 5))
+;; (miller (amb 1 2 3 4 5))
+;; (smith (amb 1 2 3 4 5)))
+;; (require
+;; (distinct? (list baker cooper fletcher miller smith)))
+;; (require (not (= baker 5)))
+;; (require (not (= cooper 1)))
+;; (require (not (= fletcher 5)))
+;; (require (not (= fletcher 1)))
+;; (require (> miller cooper))
+;; (require (not (= (abs (- smith fletcher)) 1)))
+;; (require (not (= (abs (- fletcher cooper)) 1)))
+;; (list (list 'baker baker)
+;; (list 'cooper cooper)
+;; (list 'fletcher fletcher)
+;; (list 'miller miller)
+;; (list 'smith smith)))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+;; (test-eval '(multiple-dwelling)
+;; '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+;; Exercise 4.40. In the multiple dwelling problem, how many sets of assignments are there of people to floors, both before and after the requirement that floor assignments be distinct? It is very inefficient to generate all possible assignments of people to floors and then leave it to backtracking to eliminate them. For example, most of the restrictions depend on only one or two of the person-floor variables, and can thus be imposed before floors have been selected for all the people. Write and demonstrate a much more efficient nondeterministic procedure that solves this problem based upon generating only those possibilities that are not already ruled out by previous restrictions. (Hint: This will require a nest of let expressions.)
+
+(geval
+ '(define (multiple-dwelling)
+ (let* ((fletcher (amb 2 3 4))
+ (baker (amb 1 2 3 4))
+ (cooper (amb 2 3 4 5)))
+ (require (not (= (abs (- fletcher cooper)) 1)))
+ (let ((miller (amb 1 2 3 4 5)))
+ (require (> miller cooper))
+ (let ((smith (amb 1 2 3 4 5)))
+ (require (not (= (abs (- smith fletcher)) 1)))
+ (require
+ (distinct?
+ (list baker cooper fletcher miller smith)))
+ (list (list 'baker baker)
+ (list 'cooper cooper)
+ (list 'fletcher fletcher)
+ (list 'miller miller)
+ (list 'smith smith)))))))
+(test-eval '(multiple-dwelling)
+ '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+
blob - /dev/null
blob + 995ec71cbfb390b5d73f90a5109c517f05d5f2de (mode 644)
--- /dev/null
+++ ex4-40.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+;; (geval
+;; '(define (multiple-dwelling)
+;; (let ((baker (amb 1 2 3 4 5))
+;; (cooper (amb 1 2 3 4 5))
+;; (fletcher (amb 1 2 3 4 5))
+;; (miller (amb 1 2 3 4 5))
+;; (smith (amb 1 2 3 4 5)))
+;; (require
+;; (distinct? (list baker cooper fletcher miller smith)))
+;; (require (not (= baker 5)))
+;; (require (not (= cooper 1)))
+;; (require (not (= fletcher 5)))
+;; (require (not (= fletcher 1)))
+;; (require (> miller cooper))
+;; (require (not (= (abs (- smith fletcher)) 1)))
+;; (require (not (= (abs (- fletcher cooper)) 1)))
+;; (list (list 'baker baker)
+;; (list 'cooper cooper)
+;; (list 'fletcher fletcher)
+;; (list 'miller miller)
+;; (list 'smith smith)))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+;; (test-eval '(multiple-dwelling)
+;; '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+;; 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.
+
+;; the order doesn't matter as for correctness, but it does affect speed
+;; require is slow because it must, for each element, check through all the remaining elements
+
+(geval
+ '(define (multiple-dwelling)
+ (let ((baker (amb 1 2 3 4 5))
+ (cooper (amb 1 2 3 4 5))
+ (fletcher (amb 1 2 3 4 5))
+ (miller (amb 1 2 3 4 5))
+ (smith (amb 1 2 3 4 5)))
+ (require (> miller cooper))
+ (require (not (= baker 5)))
+ (require (not (= cooper 1)))
+ (require (not (= fletcher 5)))
+ (require (not (= fletcher 1)))
+ (require (not (= (abs (- smith fletcher)) 1)))
+ (require (not (= (abs (- fletcher cooper)) 1)))
+ (require
+ (distinct? (list baker cooper fletcher miller smith)))
+ (list (list 'baker baker)
+ (list 'cooper cooper)
+ (list 'fletcher fletcher)
+ (list 'miller miller)
+ (list 'smith smith)))))
+
+;; this is going to be significantly faster
blob - /dev/null
blob + dc505ed7635b0b1e73cc735cb251752c5a306c33 (mode 644)
--- /dev/null
+++ ex4-41.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+;; (geval
+;; '(define (multiple-dwelling)
+;; (let ((baker (amb 1 2 3 4 5))
+;; (cooper (amb 1 2 3 4 5))
+;; (fletcher (amb 1 2 3 4 5))
+;; (miller (amb 1 2 3 4 5))
+;; (smith (amb 1 2 3 4 5)))
+;; (require
+;; (distinct? (list baker cooper fletcher miller smith)))
+;; (require (not (= baker 5)))
+;; (require (not (= cooper 1)))
+;; (require (not (= fletcher 5)))
+;; (require (not (= fletcher 1)))
+;; (require (> miller cooper))
+;; (require (not (= (abs (- smith fletcher)) 1)))
+;; (require (not (= (abs (- fletcher cooper)) 1)))
+;; (list (list 'baker baker)
+;; (list 'cooper cooper)
+;; (list 'fletcher fletcher)
+;; (list 'miller miller)
+;; (list 'smith smith)))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+;; (test-eval '(multiple-dwelling)
+;; '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+;; Exercise 4.40. In the multiple dwelling problem, how many sets of assignments are there of people to floors, both before and after the requirement that floor assignments be distinct? It is very inefficient to generate all possible assignments of people to floors and then leave it to backtracking to eliminate them. For example, most of the restrictions depend on only one or two of the person-floor variables, and can thus be imposed before floors have been selected for all the people. Write and demonstrate a much more efficient nondeterministic procedure that solves this problem based upon generating only those possibilities that are not already ruled out by previous restrictions. (Hint: This will require a nest of let expressions.)
+
+(geval
+ '(define (multiple-dwelling)
+ (let* ((fletcher (amb 2 3 4))
+ (baker (amb 1 2 3 4))
+ (cooper (amb 2 3 4 5)))
+ (require (not (= (abs (- fletcher cooper)) 1)))
+ (let ((miller (amb 1 2 3 4 5)))
+ (require (> miller cooper))
+ (let ((smith (amb 1 2 3 4 5)))
+ (require (not (= (abs (- smith fletcher)) 1)))
+ (require
+ (distinct?
+ (list baker cooper fletcher miller smith)))
+ (list (list 'baker baker)
+ (list 'cooper cooper)
+ (list 'fletcher fletcher)
+ (list 'miller miller)
+ (list 'smith smith)))))))
+(test-eval '(multiple-dwelling)
+ '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+
blob - /dev/null
blob + 2ae4b2db9982706aee1cdf690f98c51056279067 (mode 644)
--- /dev/null
+++ ex4-42.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+
+ ;; Exercise 4.42. Solve the following ``Liars'' puzzle (from Phillips 1934):
+
+ ;; Five schoolgirls sat for an examination. Their parents -- so they thought -- showed an undue degree of interest in the result. They therefore agreed that, in writing home about the examination, each girl should make one true statement and one untrue one. The following are the relevant passages from their letters:
+
+ ;; Betty: ``Kitty was second in the examination. I was only third.''
+ ;; Ethel: ``You'll be glad to hear that I was on top. Joan was second.''
+ ;; Joan: ``I was third, and poor old Ethel was bottom.''
+ ;; Kitty: ``I came out second. Mary was only fourth.''
+ ;; Mary: ``I was fourth. Top place was taken by Betty.''
+
+ ;; What in fact was the order in which the five girls were placed?
+
+
+(geval
+ '(define (liars)
+ (let ((betty (amb 1 2 3 4 5))
+ (ethel (amb 1 2 3 4 5))
+ (joan (amb 1 2 3 4 5))
+ (kitty (amb 1 2 3 4 5))
+ (mary (amb 1 2 3 4 5)))
+ (require (xor (= kitty 2) (= betty 3)))
+ (require (xor (= ethel 1) (= joan 2)))
+ (require (xor (= joan 3) (= ethel 5)))
+ (require (xor (= kitty 2) (= mary 4)))
+ (require (xor (= mary 4) (= betty 1)))
+ (require (distinct? (list betty ethel joan kitty mary)))
+ (list (list 'betty betty)
+ (list 'ethel ethel)
+ (list 'joan joan)
+ (list 'kitty kitty)
+ (list 'mary mary)))))
+(user-print (geval '(liars)))
+(newline)
+(user-print (geval 'try-again))
+
blob - /dev/null
blob + dc505ed7635b0b1e73cc735cb251752c5a306c33 (mode 644)
--- /dev/null
+++ ex4-42.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+;; (geval
+;; '(define (multiple-dwelling)
+;; (let ((baker (amb 1 2 3 4 5))
+;; (cooper (amb 1 2 3 4 5))
+;; (fletcher (amb 1 2 3 4 5))
+;; (miller (amb 1 2 3 4 5))
+;; (smith (amb 1 2 3 4 5)))
+;; (require
+;; (distinct? (list baker cooper fletcher miller smith)))
+;; (require (not (= baker 5)))
+;; (require (not (= cooper 1)))
+;; (require (not (= fletcher 5)))
+;; (require (not (= fletcher 1)))
+;; (require (> miller cooper))
+;; (require (not (= (abs (- smith fletcher)) 1)))
+;; (require (not (= (abs (- fletcher cooper)) 1)))
+;; (list (list 'baker baker)
+;; (list 'cooper cooper)
+;; (list 'fletcher fletcher)
+;; (list 'miller miller)
+;; (list 'smith smith)))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+;; (test-eval '(multiple-dwelling)
+;; '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+;; Exercise 4.40. In the multiple dwelling problem, how many sets of assignments are there of people to floors, both before and after the requirement that floor assignments be distinct? It is very inefficient to generate all possible assignments of people to floors and then leave it to backtracking to eliminate them. For example, most of the restrictions depend on only one or two of the person-floor variables, and can thus be imposed before floors have been selected for all the people. Write and demonstrate a much more efficient nondeterministic procedure that solves this problem based upon generating only those possibilities that are not already ruled out by previous restrictions. (Hint: This will require a nest of let expressions.)
+
+(geval
+ '(define (multiple-dwelling)
+ (let* ((fletcher (amb 2 3 4))
+ (baker (amb 1 2 3 4))
+ (cooper (amb 2 3 4 5)))
+ (require (not (= (abs (- fletcher cooper)) 1)))
+ (let ((miller (amb 1 2 3 4 5)))
+ (require (> miller cooper))
+ (let ((smith (amb 1 2 3 4 5)))
+ (require (not (= (abs (- smith fletcher)) 1)))
+ (require
+ (distinct?
+ (list baker cooper fletcher miller smith)))
+ (list (list 'baker baker)
+ (list 'cooper cooper)
+ (list 'fletcher fletcher)
+ (list 'miller miller)
+ (list 'smith smith)))))))
+(test-eval '(multiple-dwelling)
+ '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+
blob - /dev/null
blob + fd7eda0474d6c12d6287110d3edc6dc224617d7e (mode 644)
--- /dev/null
+++ ex4-43.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+;; Exercise 4.43. Use the amb evaluator to solve the following puzzle:49
+
+;; 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.
+;; Gabrielle's father owns the yacht that is named after Dr. Parker's daughter. Who is Lorna's father?
+
+;; 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.
+
+;;barnacle - mellisa
+;;(moore downing hall barnacle-hood parker)
+;; ((eq? gabrielle 'hall) ...))
+
+(geval
+ '(define (yacht)
+ (let* ((mary-ann 'moore)
+ (melissa 'barnacle-hood)
+ (gabrielle (amb 'downing 'hall))
+ (lorna (amb 'downing 'hall 'parker)))
+ (require (not (eq? gabrielle lorna)))
+ (let ((rosalind (amb 'downing 'parker)))
+ (require (not (member rosalind (list gabrielle lorna))))
+ (require (if (eq? gabrielle 'downing)
+ (eq? lorna 'parker)
+ (eq? rosalind 'parker)))
+;; (require (distinct? (list mary-ann melissa gabrielle lorna rosalind)))
+ (list 'lorna lorna)))))
+
+(user-print (geval '(yacht)))
+(newline)
+(user-print (geval 'try-again))
+(user-print (geval 'try-again))
+(user-print (geval 'try-again))
+(user-print (geval 'try-again))
+(user-print (geval 'try-again))
+
+
blob - /dev/null
blob + 2ae4b2db9982706aee1cdf690f98c51056279067 (mode 644)
--- /dev/null
+++ ex4-43.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+
+ ;; Exercise 4.42. Solve the following ``Liars'' puzzle (from Phillips 1934):
+
+ ;; Five schoolgirls sat for an examination. Their parents -- so they thought -- showed an undue degree of interest in the result. They therefore agreed that, in writing home about the examination, each girl should make one true statement and one untrue one. The following are the relevant passages from their letters:
+
+ ;; Betty: ``Kitty was second in the examination. I was only third.''
+ ;; Ethel: ``You'll be glad to hear that I was on top. Joan was second.''
+ ;; Joan: ``I was third, and poor old Ethel was bottom.''
+ ;; Kitty: ``I came out second. Mary was only fourth.''
+ ;; Mary: ``I was fourth. Top place was taken by Betty.''
+
+ ;; What in fact was the order in which the five girls were placed?
+
+
+(geval
+ '(define (liars)
+ (let ((betty (amb 1 2 3 4 5))
+ (ethel (amb 1 2 3 4 5))
+ (joan (amb 1 2 3 4 5))
+ (kitty (amb 1 2 3 4 5))
+ (mary (amb 1 2 3 4 5)))
+ (require (xor (= kitty 2) (= betty 3)))
+ (require (xor (= ethel 1) (= joan 2)))
+ (require (xor (= joan 3) (= ethel 5)))
+ (require (xor (= kitty 2) (= mary 4)))
+ (require (xor (= mary 4) (= betty 1)))
+ (require (distinct? (list betty ethel joan kitty mary)))
+ (list (list 'betty betty)
+ (list 'ethel ethel)
+ (list 'joan joan)
+ (list 'kitty kitty)
+ (list 'mary mary)))))
+(user-print (geval '(liars)))
+(newline)
+(user-print (geval 'try-again))
+
blob - /dev/null
blob + ce81352a0534210aab1fd49474961192929fb5a9 (mode 644)
--- /dev/null
+++ ex4-44.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+
+;; 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.
+
+;; (define (queens queen-positions n)
+;; (if (= (length queen-positions) n)
+;; queen-positions
+;; (let ((new-position (amb 1 2 3 4 5 6 7 8)))
+;; (adjoin new-position queen-positions)
+;; (require (safe? queen-positions))
+;; (queens queen-positions n)
+
+(geval
+ '(define (queens board-size)
+ (define (queen-cols k)
+ (if (= k 0)
+ empty-board
+ (let* ((new-position (an-integer-between 1 board-size))
+ (new-positions
+ (adjoin-position new-position k (queen-cols (- k 1)))))
+ (require (safe? k new-positions))
+ new-positions)))
+ (queen-cols board-size)))
+
+;; 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.
+(geval
+ '(define empty-board '()))
+
+;; take positions and append new-queen-row in the (new-queen-col - 1)st position in the list
+(geval
+ '(define (adjoin-position new-queen-row new-queen-col positions)
+ (append positions
+ (list new-queen-row))))
+
+(geval
+ '(define (safe? col positions)
+ (define (exclude-last lst)
+ (cond ((null? lst) (error "empty list"))
+ ((null? (cdr lst)) '())
+ (else (cons (car lst) (exclude-last (cdr lst))))))
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (let ((same-row?
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ false
+ all-but-last))
+ (same-positive-diagonal?
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ false
+ (map-2 + all-but-last (enumerate-interval 1 (- col 1)))))
+ (same-negative-diagonal?
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ false
+ (map-2 - all-but-last (enumerate-interval 1 (- col 1))))))
+ (not (or same-row? same-positive-diagonal? same-negative-diagonal?))))))
+
+(test-eval '(safe? 1 '(1)) #t)
+(test-eval '(safe? 4 '(2 4 1 1)) #f)
+(test-eval '(safe? 4 '(2 4 1 2)) #f)
+(test-eval '(safe? 4 '(2 4 1 3)) #t)
+(test-eval '(safe? 4 '(2 4 1 4)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 1)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 2)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 3)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 4)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 5)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 6)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 7)) #t)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+(user-print (geval '(queens 4)))
+(user-print (geval 'try-again))
+(user-print (geval 'try-again))
+(user-print (geval '(queens 5)))
+(user-print (geval 'try-again))
+(user-print (geval 'try-again))
+(user-print (geval 'try-again))
+
+;; the procedure is really slow but it works
blob - /dev/null
blob + d0f35a09d011f053062774dd953a9300154c0647 (mode 644)
--- /dev/null
+++ ex4-44.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+
+;; 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.
+
+(define (queens queen-positions n)
+ (if (= (length queen-positions) n)
+ queen-positions
+ (let ((new-position (amb 1 2 3 4 5 6 7 8)))
+ (require (new-position
+ (queens (append new-position queen-positions) n)
+
+(define (safe? col positions)
+ (define (exclude-last list)
+ (cond ((null? list) (error "empty list"))
+ ((null? (cdr list)) '())
+ (else (cons (car list) (exclude-last (cdr list))))))
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (let ((same-row?
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ #f
+ all-but-last))
+ (same-positive-diagonal?
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ #f
+ (map + all-but-last (enumerate-interval 1 (- col 1)))))
+ (same-negative-diagonal?
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ #f
+ (map - all-but-last (enumerate-interval 1 (- col 1))))))
+ (not (or same-row? same-positive-diagonal? same-negative-diagonal?)))))
blob - /dev/null
blob + 955b4432e9ddd546357350a10a26dc405252c608 (mode 644)
--- /dev/null
+++ ex4-45.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define nouns '(noun student professor cat class)))
+(geval
+ '(define verbs '(verb studies lectures eats sleeps)))
+(geval
+ '(define articles '(article the a)))
+(geval
+ '(define prepositions '(prep for to in by with)))
+
+(geval
+ '(define (parse-sentence)
+ (list 'sentence
+ (parse-noun-phrase)
+ (parse-verb-phrase))))
+(geval
+ '(define (parse-verb-phrase)
+ (define (maybe-extend verb-phrase)
+ (amb verb-phrase
+ (maybe-extend
+ (list 'verb-phrase
+ verb-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-word verbs))))
+(geval
+ '(define (parse-simple-noun-phrase)
+ (list 'simple-noun-phrase
+ (parse-word articles)
+ (parse-word nouns))))
+(geval
+ '(define (parse-noun-phrase)
+ (define (maybe-extend noun-phrase)
+ (amb noun-phrase
+ (maybe-extend
+ (list 'noun-phrase
+ noun-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-simple-noun-phrase))))
+(geval
+ '(define (parse-prepositional-phrase)
+ (list 'prep-phrase
+ (parse-word prepositions)
+ (parse-noun-phrase))))
+(geval
+ '(define (parse-word word-list)
+ (require (not (null? *unparsed*)))
+ (require (memq (car *unparsed*) (cdr word-list)))
+ (let ((found-word (car *unparsed*)))
+ (set! *unparsed* (cdr *unparsed*))
+ (list (car word-list) found-word))))
+(geval
+ '(define *unparsed* '()))
+(geval
+ '(define (parse input)
+ (set! *unparsed* input)
+ (let ((sent (parse-sentence)))
+ (require (null? *unparsed*))
+ sent)))
+
+;; (print-eval '(parse '(the cat eats)))
+;; (newline)
+;; (print-eval '(parse '(the student with the cat sleeps in the class)))
+;; (newline)
+;; (print-eval '(parse '(the professor lectures to the student with the cat)))
+;; (newline)
+;; (print-eval 'try-again)
+
+;; Exercise 4.45. With the grammar given above, the following sentence can be parsed in five different ways: ``The professor lectures to the student in the class with the cat.'' Give the five parses and explain the differences in shades of meaning among them.
+
+(print-eval '(parse '(the professor lectures to the student in the class with the cat)))
+(newline)
+(print-eval 'try-again)
+(newline)
+(print-eval 'try-again)
+(newline)
+(print-eval 'try-again)
+(newline)
+(print-eval 'try-again)
+(newline)
+(print-eval 'try-again)
blob - /dev/null
blob + ce81352a0534210aab1fd49474961192929fb5a9 (mode 644)
--- /dev/null
+++ ex4-45.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; (geval
+;; '(let ((x 5))
+;; (define y x)
+;; (define x 3)
+;; (+ x y)))
+;; signal an error because x is undefined if variables are scanned out
+
+;; letrec
+
+(geval
+ '(define (f x)
+ (letrec ((even?
+ (lambda (n)
+ (if (= n 0)
+ true
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))))
+ (even? x))))
+(test-eval '(f 11) false)
+(test-eval '(f 16) true)
+
+(test-eval
+ '(letrec ((fact
+ (lambda (n)
+ (if (= n 1)
+ 1
+ (* n (fact (- n 1)))))))
+ (fact 10))
+ 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+(geval '(define (require p) (if (not p) (amb))))
+(test-eval '(require false) "No alternatives")
+(test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+
+;; 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.
+
+;; (define (queens queen-positions n)
+;; (if (= (length queen-positions) n)
+;; queen-positions
+;; (let ((new-position (amb 1 2 3 4 5 6 7 8)))
+;; (adjoin new-position queen-positions)
+;; (require (safe? queen-positions))
+;; (queens queen-positions n)
+
+(geval
+ '(define (queens board-size)
+ (define (queen-cols k)
+ (if (= k 0)
+ empty-board
+ (let* ((new-position (an-integer-between 1 board-size))
+ (new-positions
+ (adjoin-position new-position k (queen-cols (- k 1)))))
+ (require (safe? k new-positions))
+ new-positions)))
+ (queen-cols board-size)))
+
+;; 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.
+(geval
+ '(define empty-board '()))
+
+;; take positions and append new-queen-row in the (new-queen-col - 1)st position in the list
+(geval
+ '(define (adjoin-position new-queen-row new-queen-col positions)
+ (append positions
+ (list new-queen-row))))
+
+(geval
+ '(define (safe? col positions)
+ (define (exclude-last lst)
+ (cond ((null? lst) (error "empty list"))
+ ((null? (cdr lst)) '())
+ (else (cons (car lst) (exclude-last (cdr lst))))))
+ (let ((row (list-ref positions (- col 1)))
+ (all-but-last (exclude-last positions)))
+ (let ((same-row?
+ (fold-left (lambda (result next-row)
+ (or result
+ (= next-row row)))
+ false
+ all-but-last))
+ (same-positive-diagonal?
+ (fold-left (lambda (result row-col-sum)
+ (or result
+ (= (+ row col) row-col-sum)))
+ false
+ (map-2 + all-but-last (enumerate-interval 1 (- col 1)))))
+ (same-negative-diagonal?
+ (fold-left (lambda (result row-col-dif)
+ (or result
+ (= (- row col) row-col-dif)))
+ false
+ (map-2 - all-but-last (enumerate-interval 1 (- col 1))))))
+ (not (or same-row? same-positive-diagonal? same-negative-diagonal?))))))
+
+(test-eval '(safe? 1 '(1)) #t)
+(test-eval '(safe? 4 '(2 4 1 1)) #f)
+(test-eval '(safe? 4 '(2 4 1 2)) #f)
+(test-eval '(safe? 4 '(2 4 1 3)) #t)
+(test-eval '(safe? 4 '(2 4 1 4)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 1)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 2)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 3)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 4)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 5)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 6)) #f)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 7)) #t)
+(test-eval '(safe? 7 '(2 4 6 8 3 1 8)) #f)
+
+
+(user-print (geval '(queens 4)))
+(user-print (geval 'try-again))
+(user-print (geval 'try-again))
+(user-print (geval '(queens 5)))
+(user-print (geval 'try-again))
+(user-print (geval 'try-again))
+(user-print (geval 'try-again))
+
+;; the procedure is really slow but it works
blob - /dev/null
blob + 9121231021b6bbfdb425084a7df8d4b499c37df7 (mode 644)
--- /dev/null
+++ ex4-46.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define nouns '(noun student professor cat class)))
+(geval
+ '(define verbs '(verb studies lectures eats sleeps)))
+(geval
+ '(define articles '(article the a)))
+(geval
+ '(define prepositions '(prep for to in by with)))
+
+(geval
+ '(define (parse-sentence)
+ (list 'sentence
+ (parse-noun-phrase)
+ (parse-verb-phrase))))
+(geval
+ '(define (parse-verb-phrase)
+ (define (maybe-extend verb-phrase)
+ (amb verb-phrase
+ (maybe-extend
+ (list 'verb-phrase
+ verb-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-word verbs))))
+(geval
+ '(define (parse-simple-noun-phrase)
+ (list 'simple-noun-phrase
+ (parse-word articles)
+ (parse-word nouns))))
+(geval
+ '(define (parse-noun-phrase)
+ (define (maybe-extend noun-phrase)
+ (amb noun-phrase
+ (maybe-extend
+ (list 'noun-phrase
+ noun-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-simple-noun-phrase))))
+(geval
+ '(define (parse-prepositional-phrase)
+ (list 'prep-phrase
+ (parse-word prepositions)
+ (parse-noun-phrase))))
+(geval
+ '(define (parse-word word-list)
+ (require (not (null? *unparsed*)))
+ (require (memq (car *unparsed*) (cdr word-list)))
+ (let ((found-word (car *unparsed*)))
+ (set! *unparsed* (cdr *unparsed*))
+ (list (car word-list) found-word))))
+(geval
+ '(define *unparsed* '()))
+(geval
+ '(define (parse input)
+ (set! *unparsed* input)
+ (let ((sent (parse-sentence)))
+ (require (null? *unparsed*))
+ sent)))
+
+;; (print-eval '(parse '(the cat eats)))
+;; (newline)
+;; (print-eval '(parse '(the student with the cat sleeps in the class)))
+;; (newline)
+;; (print-eval '(parse '(the professor lectures to the student with the cat)))
+;; (newline)
+;; (print-eval 'try-again)
+
+;; Exercise 4.46. The evaluators in sections 4.1 and 4.2 do not determine what order operands are evaluated in. We will see that the amb evaluator evaluates them from left to right. Explain why our parsing program wouldn't work if the operands were evaluated in some other order.
+
+;; after operands are analyzed, they are passed in order to get-args, which evalutes the car first then calls the cdr recursively to get the first arg followed by the rest of the args. Since the rest of the args are not evaluated until after the first success continuation has already received the first arg, we know that operands are evaluated in left-to-right order
+
+;; this matters because in procedures such as parse-sentence, we have:
+
+;; (list 'sentence
+;; (parse-noun-phrase)
+;; (parse-verb-phrase))
+
+;; if the operands were evaluated in right-to-left order, then the parser would attempt to parse a verb phrase before a noun phrase, but order of evaluation is important because we are modifying the *unparsed* global variable
blob - /dev/null
blob + 955b4432e9ddd546357350a10a26dc405252c608 (mode 644)
--- /dev/null
+++ ex4-46.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define nouns '(noun student professor cat class)))
+(geval
+ '(define verbs '(verb studies lectures eats sleeps)))
+(geval
+ '(define articles '(article the a)))
+(geval
+ '(define prepositions '(prep for to in by with)))
+
+(geval
+ '(define (parse-sentence)
+ (list 'sentence
+ (parse-noun-phrase)
+ (parse-verb-phrase))))
+(geval
+ '(define (parse-verb-phrase)
+ (define (maybe-extend verb-phrase)
+ (amb verb-phrase
+ (maybe-extend
+ (list 'verb-phrase
+ verb-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-word verbs))))
+(geval
+ '(define (parse-simple-noun-phrase)
+ (list 'simple-noun-phrase
+ (parse-word articles)
+ (parse-word nouns))))
+(geval
+ '(define (parse-noun-phrase)
+ (define (maybe-extend noun-phrase)
+ (amb noun-phrase
+ (maybe-extend
+ (list 'noun-phrase
+ noun-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-simple-noun-phrase))))
+(geval
+ '(define (parse-prepositional-phrase)
+ (list 'prep-phrase
+ (parse-word prepositions)
+ (parse-noun-phrase))))
+(geval
+ '(define (parse-word word-list)
+ (require (not (null? *unparsed*)))
+ (require (memq (car *unparsed*) (cdr word-list)))
+ (let ((found-word (car *unparsed*)))
+ (set! *unparsed* (cdr *unparsed*))
+ (list (car word-list) found-word))))
+(geval
+ '(define *unparsed* '()))
+(geval
+ '(define (parse input)
+ (set! *unparsed* input)
+ (let ((sent (parse-sentence)))
+ (require (null? *unparsed*))
+ sent)))
+
+;; (print-eval '(parse '(the cat eats)))
+;; (newline)
+;; (print-eval '(parse '(the student with the cat sleeps in the class)))
+;; (newline)
+;; (print-eval '(parse '(the professor lectures to the student with the cat)))
+;; (newline)
+;; (print-eval 'try-again)
+
+;; Exercise 4.45. With the grammar given above, the following sentence can be parsed in five different ways: ``The professor lectures to the student in the class with the cat.'' Give the five parses and explain the differences in shades of meaning among them.
+
+(print-eval '(parse '(the professor lectures to the student in the class with the cat)))
+(newline)
+(print-eval 'try-again)
+(newline)
+(print-eval 'try-again)
+(newline)
+(print-eval 'try-again)
+(newline)
+(print-eval 'try-again)
+(newline)
+(print-eval 'try-again)
blob - /dev/null
blob + ba227c5d80e9ab85cf00818ca32d92c171f330e5 (mode 644)
--- /dev/null
+++ ex4-47.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define nouns '(noun student professor cat class)))
+(geval
+ '(define verbs '(verb studies lectures eats sleeps)))
+(geval
+ '(define articles '(article the a)))
+(geval
+ '(define prepositions '(prep for to in by with)))
+
+(geval
+ '(define (parse-sentence)
+ (list 'sentence
+ (parse-noun-phrase)
+ (parse-verb-phrase))))
+(geval
+ '(define (parse-verb-phrase)
+ (define (maybe-extend verb-phrase)
+ (amb verb-phrase
+ (maybe-extend
+ (list 'verb-phrase
+ verb-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-word verbs))))
+(geval
+ '(define (parse-simple-noun-phrase)
+ (list 'simple-noun-phrase
+ (parse-word articles)
+ (parse-word nouns))))
+(geval
+ '(define (parse-noun-phrase)
+ (define (maybe-extend noun-phrase)
+ (amb noun-phrase
+ (maybe-extend
+ (list 'noun-phrase
+ noun-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-simple-noun-phrase))))
+(geval
+ '(define (parse-prepositional-phrase)
+ (list 'prep-phrase
+ (parse-word prepositions)
+ (parse-noun-phrase))))
+(geval
+ '(define (parse-word word-list)
+ (require (not (null? *unparsed*)))
+ (require (memq (car *unparsed*) (cdr word-list)))
+ (let ((found-word (car *unparsed*)))
+ (set! *unparsed* (cdr *unparsed*))
+ (list (car word-list) found-word))))
+(geval
+ '(define *unparsed* '()))
+(geval
+ '(define (parse input)
+ (set! *unparsed* input)
+ (let ((sent (parse-sentence)))
+ (require (null? *unparsed*))
+ sent)))
+
+;; (print-eval '(parse '(the cat eats)))
+;; (newline)
+;; (print-eval '(parse '(the student with the cat sleeps in the class)))
+;; (newline)
+;; (print-eval '(parse '(the professor lectures to the student with the cat)))
+;; (newline)
+;; (print-eval 'try-again)
+
+;; Exercise 4.47. Louis Reasoner suggests that, since a verb phrase is either a verb or a verb phrase followed by a prepositional phrase, it would be much more straightforward to define the procedure parse-verb-phrase as follows (and similarly for noun phrases):
+
+(define (parse-verb-phrase)
+ (amb (parse-word verbs)
+ (list 'verb-phrase
+ (parse-verb-phrase)
+ (parse-prepositional-phrase))))
+
+;; Does this work? Does the program's behavior change if we interchange the order of expressions in the amb?
+
+;; (define (parse-verb-phrase)
+;; (amb (parse-word verbs)
+;; (list 'verb-phrase
+;; --> (parse-verb-phrase)
+;; (parse-prepositional-phrase))))
+
+;; it works for the first choice but none thereafter.
+;; the problem is that (amb) will never be called, even if there is no prepositional phrase after the verb phrase. Every time, parse-verb-phrase would attempt to deeper and deeper in the place with the arrow and the original failure continuation would never be called.
+
+;; (define (parse-verb-phrase)
+;; (amb (list 'verb-phrase
+;; (parse-verb-phrase)
+;; (parse-prepositional-phrase))
+;; (parse-word verbs)))
+
+;; it's even worse to swap the order of the amb choices. Now, you end up with an infinite loop
blob - /dev/null
blob + 9121231021b6bbfdb425084a7df8d4b499c37df7 (mode 644)
--- /dev/null
+++ ex4-47.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define nouns '(noun student professor cat class)))
+(geval
+ '(define verbs '(verb studies lectures eats sleeps)))
+(geval
+ '(define articles '(article the a)))
+(geval
+ '(define prepositions '(prep for to in by with)))
+
+(geval
+ '(define (parse-sentence)
+ (list 'sentence
+ (parse-noun-phrase)
+ (parse-verb-phrase))))
+(geval
+ '(define (parse-verb-phrase)
+ (define (maybe-extend verb-phrase)
+ (amb verb-phrase
+ (maybe-extend
+ (list 'verb-phrase
+ verb-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-word verbs))))
+(geval
+ '(define (parse-simple-noun-phrase)
+ (list 'simple-noun-phrase
+ (parse-word articles)
+ (parse-word nouns))))
+(geval
+ '(define (parse-noun-phrase)
+ (define (maybe-extend noun-phrase)
+ (amb noun-phrase
+ (maybe-extend
+ (list 'noun-phrase
+ noun-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-simple-noun-phrase))))
+(geval
+ '(define (parse-prepositional-phrase)
+ (list 'prep-phrase
+ (parse-word prepositions)
+ (parse-noun-phrase))))
+(geval
+ '(define (parse-word word-list)
+ (require (not (null? *unparsed*)))
+ (require (memq (car *unparsed*) (cdr word-list)))
+ (let ((found-word (car *unparsed*)))
+ (set! *unparsed* (cdr *unparsed*))
+ (list (car word-list) found-word))))
+(geval
+ '(define *unparsed* '()))
+(geval
+ '(define (parse input)
+ (set! *unparsed* input)
+ (let ((sent (parse-sentence)))
+ (require (null? *unparsed*))
+ sent)))
+
+;; (print-eval '(parse '(the cat eats)))
+;; (newline)
+;; (print-eval '(parse '(the student with the cat sleeps in the class)))
+;; (newline)
+;; (print-eval '(parse '(the professor lectures to the student with the cat)))
+;; (newline)
+;; (print-eval 'try-again)
+
+;; Exercise 4.46. The evaluators in sections 4.1 and 4.2 do not determine what order operands are evaluated in. We will see that the amb evaluator evaluates them from left to right. Explain why our parsing program wouldn't work if the operands were evaluated in some other order.
+
+;; after operands are analyzed, they are passed in order to get-args, which evalutes the car first then calls the cdr recursively to get the first arg followed by the rest of the args. Since the rest of the args are not evaluated until after the first success continuation has already received the first arg, we know that operands are evaluated in left-to-right order
+
+;; this matters because in procedures such as parse-sentence, we have:
+
+;; (list 'sentence
+;; (parse-noun-phrase)
+;; (parse-verb-phrase))
+
+;; if the operands were evaluated in right-to-left order, then the parser would attempt to parse a verb phrase before a noun phrase, but order of evaluation is important because we are modifying the *unparsed* global variable
blob - /dev/null
blob + 1706c9190571b0abbb3bebb3a5555461dfbb2ff3 (mode 644)
--- /dev/null
+++ ex4-48.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define nouns '(noun student professor cat class)))
+(geval
+ '(define verbs '(verb studies lectures eats sleeps)))
+(geval
+ '(define articles '(article the a)))
+(geval
+ '(define prepositions '(prep for to in by with)))
+
+(geval
+ '(define (parse-sentence)
+ (list 'sentence
+ (parse-noun-phrase)
+ (parse-verb-phrase))))
+(geval
+ '(define (parse-verb-phrase)
+ (define (maybe-extend verb-phrase)
+ (amb verb-phrase
+ (maybe-extend
+ (list 'verb-phrase
+ verb-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-word verbs))))
+(geval
+ '(define (parse-simple-noun-phrase)
+ (list 'simple-noun-phrase
+ (parse-word articles)
+ (parse-word nouns))))
+(geval
+ '(define (parse-noun-phrase)
+ (define (maybe-extend noun-phrase)
+ (amb noun-phrase
+ (maybe-extend
+ (list 'noun-phrase
+ noun-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-simple-noun-phrase))))
+(geval
+ '(define (parse-prepositional-phrase)
+ (list 'prep-phrase
+ (parse-word prepositions)
+ (parse-noun-phrase))))
+(geval
+ '(define (parse-word word-list)
+ (require (not (null? *unparsed*)))
+ (require (memq (car *unparsed*) (cdr word-list)))
+ (let ((found-word (car *unparsed*)))
+ (set! *unparsed* (cdr *unparsed*))
+ (list (car word-list) found-word))))
+(geval
+ '(define *unparsed* '()))
+(geval
+ '(define (parse input)
+ (set! *unparsed* input)
+ (let ((sent (parse-sentence)))
+ (require (null? *unparsed*))
+ sent)))
+
+;; (print-eval '(parse '(the cat eats)))
+;; (newline)
+;; (print-eval '(parse '(the student with the cat sleeps in the class)))
+;; (newline)
+;; (print-eval '(parse '(the professor lectures to the student with the cat)))
+;; (newline)
+;; (print-eval 'try-again)
+
+ Exercise 4.48. Extend the grammar given above to handle more complex sentences. For example, you could extend noun phrases and verb phrases to include adjectives and adverbs, or you could handle compound sentences.53
blob - /dev/null
blob + ba227c5d80e9ab85cf00818ca32d92c171f330e5 (mode 644)
--- /dev/null
+++ ex4-48.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define nouns '(noun student professor cat class)))
+(geval
+ '(define verbs '(verb studies lectures eats sleeps)))
+(geval
+ '(define articles '(article the a)))
+(geval
+ '(define prepositions '(prep for to in by with)))
+
+(geval
+ '(define (parse-sentence)
+ (list 'sentence
+ (parse-noun-phrase)
+ (parse-verb-phrase))))
+(geval
+ '(define (parse-verb-phrase)
+ (define (maybe-extend verb-phrase)
+ (amb verb-phrase
+ (maybe-extend
+ (list 'verb-phrase
+ verb-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-word verbs))))
+(geval
+ '(define (parse-simple-noun-phrase)
+ (list 'simple-noun-phrase
+ (parse-word articles)
+ (parse-word nouns))))
+(geval
+ '(define (parse-noun-phrase)
+ (define (maybe-extend noun-phrase)
+ (amb noun-phrase
+ (maybe-extend
+ (list 'noun-phrase
+ noun-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-simple-noun-phrase))))
+(geval
+ '(define (parse-prepositional-phrase)
+ (list 'prep-phrase
+ (parse-word prepositions)
+ (parse-noun-phrase))))
+(geval
+ '(define (parse-word word-list)
+ (require (not (null? *unparsed*)))
+ (require (memq (car *unparsed*) (cdr word-list)))
+ (let ((found-word (car *unparsed*)))
+ (set! *unparsed* (cdr *unparsed*))
+ (list (car word-list) found-word))))
+(geval
+ '(define *unparsed* '()))
+(geval
+ '(define (parse input)
+ (set! *unparsed* input)
+ (let ((sent (parse-sentence)))
+ (require (null? *unparsed*))
+ sent)))
+
+;; (print-eval '(parse '(the cat eats)))
+;; (newline)
+;; (print-eval '(parse '(the student with the cat sleeps in the class)))
+;; (newline)
+;; (print-eval '(parse '(the professor lectures to the student with the cat)))
+;; (newline)
+;; (print-eval 'try-again)
+
+;; Exercise 4.47. Louis Reasoner suggests that, since a verb phrase is either a verb or a verb phrase followed by a prepositional phrase, it would be much more straightforward to define the procedure parse-verb-phrase as follows (and similarly for noun phrases):
+
+(define (parse-verb-phrase)
+ (amb (parse-word verbs)
+ (list 'verb-phrase
+ (parse-verb-phrase)
+ (parse-prepositional-phrase))))
+
+;; Does this work? Does the program's behavior change if we interchange the order of expressions in the amb?
+
+;; (define (parse-verb-phrase)
+;; (amb (parse-word verbs)
+;; (list 'verb-phrase
+;; --> (parse-verb-phrase)
+;; (parse-prepositional-phrase))))
+
+;; it works for the first choice but none thereafter.
+;; the problem is that (amb) will never be called, even if there is no prepositional phrase after the verb phrase. Every time, parse-verb-phrase would attempt to deeper and deeper in the place with the arrow and the original failure continuation would never be called.
+
+;; (define (parse-verb-phrase)
+;; (amb (list 'verb-phrase
+;; (parse-verb-phrase)
+;; (parse-prepositional-phrase))
+;; (parse-word verbs)))
+
+;; it's even worse to swap the order of the amb choices. Now, you end up with an infinite loop
blob - /dev/null
blob + f42a4c6ac225a41da03870366de719d309e818ac (mode 644)
--- /dev/null
+++ ex4-49.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define nouns '(noun student professor cat class)))
+(geval
+ '(define verbs '(verb studies lectures eats sleeps)))
+(geval
+ '(define articles '(article the a)))
+(geval
+ '(define prepositions '(prep for to in by with)))
+
+(geval
+ '(define (parse-sentence)
+ (list 'sentence
+ (parse-noun-phrase)
+ (parse-verb-phrase))))
+(geval
+ '(define (parse-verb-phrase)
+ (define (maybe-extend verb-phrase)
+ (amb verb-phrase
+ (maybe-extend
+ (list 'verb-phrase
+ verb-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-word verbs))))
+(geval
+ '(define (parse-simple-noun-phrase)
+ (list 'simple-noun-phrase
+ (parse-word articles)
+ (parse-word nouns))))
+(geval
+ '(define (parse-noun-phrase)
+ (define (maybe-extend noun-phrase)
+ (amb noun-phrase
+ (maybe-extend
+ (list 'noun-phrase
+ noun-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-simple-noun-phrase))))
+(geval
+ '(define (parse-prepositional-phrase)
+ (list 'prep-phrase
+ (parse-word prepositions)
+ (parse-noun-phrase))))
+(geval
+ '(define *unparsed* '()))
+(geval
+ '(define (parse input)
+ (set! *unparsed* input)
+ (let ((sent (parse-sentence)))
+ (require (null? *unparsed*))
+ sent)))
+
+;; Exercise 4.49. Alyssa P. Hacker is more interested in generating interesting sentences than in parsing them. She reasons that by simply changing the procedure parse-word so that it ignores the ``input sentence'' and instead always succeeds and generates an appropriate word, we can use the programs we had built for parsing to do generation instead. Implement Alyssa's idea, and show the first half-dozen or so sentences generated.54
+
+(geval
+ '(define (an-element-of items)
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define (parse-word word-list)
+ (let ((found-word (an-element-of (cdr word-list))))
+ (set! *unparsed* (append *unparsed* (list found-word)))
+ (list (car word-list) found-word))))
+
+(print-eval '(parse-sentence))
+(print-eval 'try-again)
+(print-eval 'try-again)
+
+ Exercise 4.50. Implement a new special form ramb that is like amb except that it searches alternatives in a random order, rather than from left to right. Show how this can help with Alyssa's problem in exercise 4.49.
blob - /dev/null
blob + 1706c9190571b0abbb3bebb3a5555461dfbb2ff3 (mode 644)
--- /dev/null
+++ ex4-49.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define nouns '(noun student professor cat class)))
+(geval
+ '(define verbs '(verb studies lectures eats sleeps)))
+(geval
+ '(define articles '(article the a)))
+(geval
+ '(define prepositions '(prep for to in by with)))
+
+(geval
+ '(define (parse-sentence)
+ (list 'sentence
+ (parse-noun-phrase)
+ (parse-verb-phrase))))
+(geval
+ '(define (parse-verb-phrase)
+ (define (maybe-extend verb-phrase)
+ (amb verb-phrase
+ (maybe-extend
+ (list 'verb-phrase
+ verb-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-word verbs))))
+(geval
+ '(define (parse-simple-noun-phrase)
+ (list 'simple-noun-phrase
+ (parse-word articles)
+ (parse-word nouns))))
+(geval
+ '(define (parse-noun-phrase)
+ (define (maybe-extend noun-phrase)
+ (amb noun-phrase
+ (maybe-extend
+ (list 'noun-phrase
+ noun-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-simple-noun-phrase))))
+(geval
+ '(define (parse-prepositional-phrase)
+ (list 'prep-phrase
+ (parse-word prepositions)
+ (parse-noun-phrase))))
+(geval
+ '(define (parse-word word-list)
+ (require (not (null? *unparsed*)))
+ (require (memq (car *unparsed*) (cdr word-list)))
+ (let ((found-word (car *unparsed*)))
+ (set! *unparsed* (cdr *unparsed*))
+ (list (car word-list) found-word))))
+(geval
+ '(define *unparsed* '()))
+(geval
+ '(define (parse input)
+ (set! *unparsed* input)
+ (let ((sent (parse-sentence)))
+ (require (null? *unparsed*))
+ sent)))
+
+;; (print-eval '(parse '(the cat eats)))
+;; (newline)
+;; (print-eval '(parse '(the student with the cat sleeps in the class)))
+;; (newline)
+;; (print-eval '(parse '(the professor lectures to the student with the cat)))
+;; (newline)
+;; (print-eval 'try-again)
+
+ Exercise 4.48. Extend the grammar given above to handle more complex sentences. For example, you could extend noun phrases and verb phrases to include adjectives and adverbs, or you could handle compound sentences.53
blob - /dev/null
blob + d6b6ae763ac7a97a52728d1a95ad9a9000976fc2 (mode 644)
--- /dev/null
+++ ex4-5-2.scm
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; Exercise 4.4. Recall the definitions of the special forms and and or from chapter 1:
+
+;; and: The expressions are evaluated from left to right. If any expression evaluates to false, false is returned; any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then true is returned.
+
+;; or: The expressions are evaluated from left to right. If any expression evaluates to a true value, that value is returned; any remaining expressions are not evaluated. If all expressions evaluate to false, or if there are no expressions, then false is returned.
+
+;; Install and and or as new special forms for the evaluator by defining appropriate syntax procedures and evaluation procedures eval-and and eval-or. Alternatively, show how to implement and and or as derived expressions.
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+;; (define (and->if exp)
+;; (define (expand-clauses clauses)
+;; (cond ((null? clauses) 'true)
+;; ((null? (cdr clauses)) (car clauses))
+;; (else (make-if (car clauses)
+;; (expand-clauses (cdr clauses))
+;; 'false))))
+;; (expand-clauses (and-clauses exp)))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+;; the problem with this definition is that each clause will be evaluated twice; this is unacceptable if there are side effects
+;; (define (or->if exp)
+;; (define (expand-clauses clauses)
+;; (if (null? clauses)
+;; 'false
+;; (make-if (car clauses)
+;; (car clauses)
+;; (expand-clauses (cdr clauses)))))
+;; (expand-clauses (or-clauses exp)))
+
+
+;; we can also install and/or as special forms
+
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; Exercise 4.5. Scheme allows an additional syntax for cond clauses, (<test> => <recipient>). If <test> evaluates to a true value, then <recipient> is evaluated. Its value must be a procedure of one argument; this procedure is then invoked on the value of the <test>, and the result is returned as the value of the cond expression. For example
+
+;; (cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+
+;; returns 2. Modify the handling of cond so that it supports this extended syntax.
+
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; cond
+
+(test-case
+ (geval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false)))
+ 2)
+
+(test-case
+ (geval '((lambda (x)
+ (accumulate + 0 x))
+ (map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))))
+ 118)
+
+(test-case
+ (geval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach)))
+ 118)
+;; '(6 20 2 90)
+
+
+;; test-suite
+
+;; make-let
+(test-case (geval (make-let '(x y) '(3 5) '((+ x y))))
+ 8)
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-case (geval '(and 0 true x)) 11)
+(test-case (geval '(and 0 true x false)) false)
+(test-case (geval '(and 0 true x (set! x -2) false)) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(and 0 true x false (set! x -5))) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(or false (set! x 25))) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or (set! x 2) (set! x 4))) 'ok)
+(test-case (geval 'x) 2)
+(test-case (geval '(or false (set! x 25) true false)) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or ((lambda (x) x) 5))) 5)
+(test-case (geval '(or (begin (set! x (+ x 1)) x))) 26)
+
+
+;; all special forms
+(test-case (geval '(begin 5 6)) 6)
+(test-case (geval '10) 10)
+(geval '(define x 3))
+(test-case (geval 'x) 3)
+(test-case (geval '(set! x -25)) 'ok)
+(test-case (geval 'x) -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-case (geval '(z 3 4)) 15)
+(test-case (geval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-case (geval '(if true false true)) false)
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-case (geval '(factorial 5)) 120)
+
+;; map
+
+(test-case
+ (geval '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3)))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-case
+ (geval
+ '(accumulate + 0 '(1 2 3 4 5)))
+ 15)
blob - /dev/null
blob + 7611420d8dae0f6af73b6f7ebfb4c19d27aaed2a (mode 644)
--- /dev/null
+++ ex4-5-2.scm~
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; Exercise 4.4. Recall the definitions of the special forms and and or from chapter 1:
+
+;; and: The expressions are evaluated from left to right. If any expression evaluates to false, false is returned; any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then true is returned.
+
+;; or: The expressions are evaluated from left to right. If any expression evaluates to a true value, that value is returned; any remaining expressions are not evaluated. If all expressions evaluate to false, or if there are no expressions, then false is returned.
+
+;; Install and and or as new special forms for the evaluator by defining appropriate syntax procedures and evaluation procedures eval-and and eval-or. Alternatively, show how to implement and and or as derived expressions.
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+;; (define (and->if exp)
+;; (define (expand-clauses clauses)
+;; (cond ((null? clauses) 'true)
+;; ((null? (cdr clauses)) (car clauses))
+;; (else (make-if (car clauses)
+;; (expand-clauses (cdr clauses))
+;; 'false))))
+;; (expand-clauses (and-clauses exp)))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+;; the problem with this definition is that each clause will be evaluated twice; this is unacceptable if there are side effects
+;; (define (or->if exp)
+;; (define (expand-clauses clauses)
+;; (if (null? clauses)
+;; 'false
+;; (make-if (car clauses)
+;; (car clauses)
+;; (expand-clauses (cdr clauses)))))
+;; (expand-clauses (or-clauses exp)))
+
+
+;; we can also install and/or as special forms
+
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; Exercise 4.5. Scheme allows an additional syntax for cond clauses, (<test> => <recipient>). If <test> evaluates to a true value, then <recipient> is evaluated. Its value must be a procedure of one argument; this procedure is then invoked on the value of the <test>, and the result is returned as the value of the cond expression. For example
+
+;; (cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+
+;; returns 2. Modify the handling of cond so that it supports this extended syntax.
+
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (eq? (cadr clause) '=>))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; cond
+
+(test-case
+ (geval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false)))
+ 2)
+
+(test-case
+ (geval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach)))
+ 118)
+'(6 20 2 90)
+
+
+;; test-suite
+
+;; make-let
+(test-case (geval (make-let '(x y) '(3 5) '((+ x y))))
+ 8)
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-case (geval '(and 0 true x)) 11)
+(test-case (geval '(and 0 true x false)) false)
+(test-case (geval '(and 0 true x (set! x -2) false)) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(and 0 true x false (set! x -5))) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(or false (set! x 25))) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or (set! x 2) (set! x 4))) 'ok)
+(test-case (geval 'x) 2)
+(test-case (geval '(or false (set! x 25) true false)) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or ((lambda (x) x) 5))) 5)
+(test-case (geval '(or (begin (set! x (+ x 1)) x))) 26)
+
+
+;; all special forms
+(test-case (geval '(begin 5 6)) 6)
+(test-case (geval '10) 10)
+(geval '(define x 3))
+(test-case (geval 'x) 3)
+(test-case (geval '(set! x -25)) 'ok)
+(test-case (geval 'x) -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-case (geval '(z 3 4)) 15)
+(test-case (geval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-case (geval '(if true false true)) false)
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-case (geval '(factorial 5)) 120)
+
+;; map
+
+(test-case
+ (geval '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3)))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-case
+ (geval
+ '(accumulate + 0 '(1 2 3 4 5)))
+ 15)
blob - /dev/null
blob + ad6253cc999d41c8eab889e07cae1f7787451c15 (mode 644)
--- /dev/null
+++ ex4-5.lisp
+(defun expand-cond-clauses (clauses)
+ (if (null clauses)
+ 'false
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (cond
+ ((cond-else-clause? first)
+ (if (null rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last " clauses)))
+ ((extended-cond-syntax? first)
+ (make-if
+ (extended-cond-test first)
+ (list
+ (extended-cond-recipient first)
+ (extended-cond-test first))
+ (expand-cond-clauses rest)))
+ (t
+ (make-if
+ (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-cond-clauses rest)))))))
blob - /dev/null
blob + a525a269ad374159bde6846a9e812f9e1982b600 (mode 644)
--- /dev/null
+++ ex4-5.scm
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; Exercise 4.4. Recall the definitions of the special forms and and or from chapter 1:
+
+;; and: The expressions are evaluated from left to right. If any expression evaluates to false, false is returned; any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then true is returned.
+
+;; or: The expressions are evaluated from left to right. If any expression evaluates to a true value, that value is returned; any remaining expressions are not evaluated. If all expressions evaluate to false, or if there are no expressions, then false is returned.
+
+;; Install and and or as new special forms for the evaluator by defining appropriate syntax procedures and evaluation procedures eval-and and eval-or. Alternatively, show how to implement and and or as derived expressions.
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+;; (define (and->if exp)
+;; (define (expand-clauses clauses)
+;; (cond ((null? clauses) 'true)
+;; ((null? (cdr clauses)) (car clauses))
+;; (else (make-if (car clauses)
+;; (expand-clauses (cdr clauses))
+;; 'false))))
+;; (expand-clauses (and-clauses exp)))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+;; the problem with this definition is that each clause will be evaluated twice; this is unacceptable if there are side effects
+;; (define (or->if exp)
+;; (define (expand-clauses clauses)
+;; (if (null? clauses)
+;; 'false
+;; (make-if (car clauses)
+;; (car clauses)
+;; (expand-clauses (cdr clauses)))))
+;; (expand-clauses (or-clauses exp)))
+
+
+;; we can also install and/or as special forms
+
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; Exercise 4.5. Scheme allows an additional syntax for cond clauses, (<test> => <recipient>). If <test> evaluates to a true value, then <recipient> is evaluated. Its value must be a procedure of one argument; this procedure is then invoked on the value of the <test>, and the result is returned as the value of the cond expression. For example
+
+;; (cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+
+;; returns 2. Modify the handling of cond so that it supports this extended syntax.
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (car (car records))) (car records))
+ (else (assoc key (cdr records))))))
+
+;; (test-case
+;; (geval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false)))
+;; 2)
+
+(geval
+ '(define (map proc . lists)
+ (define (inner-map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (inner-map proc (cdr list)))))
+ (if (null? lists)
+ '()
+ (cons (inner-map proc (inner-map car lists))
+ (map proc (inner-map cdr lists))))))
+(test-case
+ (geval '(map (lambda (x y)
+ (* x y))
+ '(2 1 4 2 8 3)
+ '(3 7 1 0 7 8)))
+ '(6 7 4 0 56 24))
+
+
+;; (test-case
+;; (geval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((assoc '
+
+;; test-suite
+
+;; make-let
+(test-case (geval (make-let '(x y) '(3 5) '((+ x y))))
+ 8)
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-case (geval '(and 0 true x)) 11)
+(test-case (geval '(and 0 true x false)) false)
+(test-case (geval '(and 0 true x (set! x -2) false)) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(and 0 true x false (set! x -5))) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(or false (set! x 25))) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or (set! x 2) (set! x 4))) 'ok)
+(test-case (geval 'x) 2)
+(test-case (geval '(or false (set! x 25) true false)) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or ((lambda (x) x) 5))) 5)
+(test-case (geval '(or (begin (set! x (+ x 1)) x))) 26)
+
+
+;; all special forms
+(test-case (geval '(begin 5 6)) 6)
+(test-case (geval '10) 10)
+(geval '(define x 3))
+(test-case (geval 'x) 3)
+(test-case (geval '(set! x -25)) 'ok)
+(test-case (geval 'x) -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-case (geval '(z 3 4)) 15)
+(test-case (geval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-case (geval '(if true false true)) false)
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-case (geval '(factorial 5)) 120)
+
+
blob - /dev/null
blob + 56b46a003124e39baa692fb4e5b8e547c0dc804c (mode 644)
--- /dev/null
+++ ex4-5.scm~
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; Exercise 4.4. Recall the definitions of the special forms and and or from chapter 1:
+
+;; and: The expressions are evaluated from left to right. If any expression evaluates to false, false is returned; any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then true is returned.
+
+;; or: The expressions are evaluated from left to right. If any expression evaluates to a true value, that value is returned; any remaining expressions are not evaluated. If all expressions evaluate to false, or if there are no expressions, then false is returned.
+
+;; Install and and or as new special forms for the evaluator by defining appropriate syntax procedures and evaluation procedures eval-and and eval-or. Alternatively, show how to implement and and or as derived expressions.
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+;; (define (and->if exp)
+;; (define (expand-clauses clauses)
+;; (cond ((null? clauses) 'true)
+;; ((null? (cdr clauses)) (car clauses))
+;; (else (make-if (car clauses)
+;; (expand-clauses (cdr clauses))
+;; 'false))))
+;; (expand-clauses (and-clauses exp)))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+;; the problem with this definition is that each clause will be evaluated twice; this is unacceptable if there are side effects
+;; (define (or->if exp)
+;; (define (expand-clauses clauses)
+;; (if (null? clauses)
+;; 'false
+;; (make-if (car clauses)
+;; (car clauses)
+;; (expand-clauses (cdr clauses)))))
+;; (expand-clauses (or-clauses exp)))
+
+
+;; we can also install and/or as special forms
+
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+;; test-suite
+
+;; make-let
+(test-case (geval (make-let '(x y) '(3 5) '((+ x y))))
+ 8)
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-case (geval '(and 0 true x)) 11)
+(test-case (geval '(and 0 true x false)) false)
+(test-case (geval '(and 0 true x (set! x -2) false)) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(and 0 true x false (set! x -5))) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(or false (set! x 25))) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or (set! x 2) (set! x 4))) 'ok)
+(test-case (geval 'x) 2)
+(test-case (geval '(or false (set! x 25) true false)) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or ((lambda (x) x) 5))) 5)
+(test-case (geval '(or (begin (set! x (+ x 1)) x))) 26)
+
+
+;; all special forms
+(test-case (geval '(begin 5 6)) 6)
+(test-case (geval '10) 10)
+(geval '(define x 3))
+(test-case (geval 'x) 3)
+(test-case (geval '(set! x -25)) 'ok)
+(test-case (geval 'x) -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-case (geval '(z 3 4)) 15)
+(test-case (geval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-case (geval '(if true false true)) false)
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-case (geval '(factorial 5)) 120)
+
+
blob - /dev/null
blob + 741764df930dc70c2d830dbdde6dcb6a72d21618 (mode 644)
--- /dev/null
+++ ex4-50.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define nouns '(noun student professor cat class)))
+(geval
+ '(define verbs '(verb studies lectures eats sleeps)))
+(geval
+ '(define articles '(article the a)))
+(geval
+ '(define prepositions '(prep for to in by with)))
+
+(geval
+ '(define (parse-sentence)
+ (list 'sentence
+ (parse-noun-phrase)
+ (parse-verb-phrase))))
+(geval
+ '(define (parse-verb-phrase)
+ (define (maybe-extend verb-phrase)
+ (ramb verb-phrase
+ (maybe-extend
+ (list 'verb-phrase
+ verb-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-word verbs))))
+(geval
+ '(define (parse-simple-noun-phrase)
+ (list 'simple-noun-phrase
+ (parse-word articles)
+ (parse-word nouns))))
+(geval
+ '(define (parse-noun-phrase)
+ (define (maybe-extend noun-phrase)
+ (ramb noun-phrase
+ (maybe-extend
+ (list 'noun-phrase
+ noun-phrase
+ (parse-prepositional-phrase)))))
+ (maybe-extend (parse-simple-noun-phrase))))
+(geval
+ '(define (parse-prepositional-phrase)
+ (list 'prep-phrase
+ (parse-word prepositions)
+ (parse-noun-phrase))))
+(geval
+ '(define *unparsed* '()))
+(geval
+ '(define (parse input)
+ (set! *unparsed* input)
+ (let ((sent (parse-sentence)))
+ (require (null? *unparsed*))
+ sent)))
+
+;; Exercise 4.49. Alyssa P. Hacker is more interested in generating interesting sentences than in parsing them. She reasons that by simply changing the procedure parse-word so that it ignores the ``input sentence'' and instead always succeeds and generates an appropriate word, we can use the programs we had built for parsing to do generation instead. Implement Alyssa's idea, and show the first half-dozen or so sentences generated.54
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (ramb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define (parse-word word-list)
+ (let ((found-word (an-element-of (cdr word-list))))
+ (set! *unparsed* (append *unparsed* (list found-word)))
+ (list (car word-list) found-word))))
+
+(print-eval '(parse-sentence))
+(print-eval 'try-again)
+(print-eval 'try-again)
+(print-eval 'try-again)
+(print-eval 'try-again)
+(print-eval 'try-again)
+(print-eval 'try-again)
+
+;; Exercise 4.50. Implement a new special form ramb that is like amb except that it searches alternatives in a random order, rather than from left to right. Show how this can help with Alyssa's problem in exercise 4.49.
+
+;; (ramb <choice1> <choice2> ... <choiceN>)
+
+;; ;; once a choice has been tried, we remove it so that
+;; ;; eventually, the failure continuation can be called
+;; (define (analyze-ramb exp)
+;; (let ((cprocs (shufle (map analyze (amb-choices)))))
+;; (lambda (env succeed fail)
+;; (define (try-next choices)
+;; (if (null? choices)
+;; (fail)
+;; ((car choices)
+;; env
+;; succeed
+;; (lambda ()
+;; (try-next (cdr choices))))))
+;; (try-next cprocs))))
+
+;; in fact, we can just use shuffle to perform a syntactic transformation
blob - /dev/null
blob + baa4e303fa909eae86cedfe167b64925b84c4afd (mode 644)
--- /dev/null
+++ ex4-50.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze-ramb exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+ (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+(newline)
+(display "Failure expected")
+(newline)
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; make-unbound!
+;; broken now due to scan-out-defines
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (* x x)))
+;; 9)
+
+;; (test-eval
+;; '(let ((x 3))
+;; (let ((x 5))
+;; (define y x)
+;; (make-unbound! x)
+;; (* y x)))
+;; 15)
+
+;; (test-eval
+;; '(let ((y -1) (x 3))
+;; (let ((y 0.5) (x 5))
+;; (define a x)
+;; (define b y)
+;; (make-unbound! x)
+;; (make-unbound! y)
+;; (* a b x y)))
+;; (* 5 3 -1 0.5))
+
+;; (test-eval
+;; '(let ((x 3) (y 4))
+;; (let ((x 5))
+;; (make-unbound! x)
+;; (+ x 4)))
+;; 7)
+
+;; (test-eval
+;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; (make-unbound! b)
+;; (+ a c d))
+;; (+ 1 3 4))
+
+;; (test-eval
+;; '(let ((x 4) (y 5))
+;; (let ((a 1) (b 2) (c 3))
+;; (let ((x (+ a b)) (y (+ c a)))
+;; (make-unbound! x)
+;; (let ((a x) (b (+ x y)))
+;; (define z b)
+;; (make-unbound! b)
+;; (* (+ a z)
+;; (+ a b y))))))
+;; (* (+ 4 8)
+;; (+ 4 2 4)))
+
+;; x 3 -- y 4
+;; x 4 -- y 4
+;; a 4 -- b 4
+;; a 4 -- b 2
+
+;; scan-out-defines
+
+(geval
+ '(define (f x)
+ (define (even? n)
+ (if (= n 0)
+ true
+ (odd? (- n 1))))
+ (define (odd? n)
+ (if (= n 0)
+ false
+ (even? (- n 1))))
+ (even? x)))
+(test-eval '(f 5) false)
+(test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(test-eval '(amb 1 2 3) 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 3)
+(test-eval 'try-again "No alternatives")
+(test-eval 'try-again "No current problem")
+(test-eval 'try-again "No current problem")
+(test-eval '(amb (amb 1 2) (amb 'a 'b))
+ 1)
+(test-eval 'try-again 2)
+(test-eval 'try-again 'a)
+(test-eval 'try-again 'b)
+(test-eval 'try-again "No alternatives")
+
+
+
+;; Exercise 4.50. Implement a new special form ramb that is like amb except that it searches alternatives in a random order, rather than from left to right. Show how this can help with Alyssa's problem in exercise 4.49.
+
+(ramb <exp1> <exp2> ... <expN>)
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb-choices exp)
+ (cdr exp))
+
blob - /dev/null
blob + d335db09fda85f5aaf01a5922d6157d51a98628a (mode 644)
--- /dev/null
+++ ex4-51.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((permanent-assignment? exp)
+ (analyze-permanent-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+(define (analyze-permanent-assignment exp)
+ (let ((var (permanent-assignment-variable exp))
+ (vproc (analyze (permanent-assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc
+ env
+ (lambda (val val-fail)
+ (set-variable-value! var val env)
+ (succeed 'ok val-fail))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/permanent-assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (permanent-assignment? exp)
+ (tagged-list? exp 'permanent-set!))
+(define permanent-assignment-variable assignment-variable)
+(define permanent-assignment-value assignment-value)
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+;; Exercise 4.51. Implement a new kind of assignment called permanent-set! that is not undone upon failure. For example, we can choose two distinct elements from a list and count the number of trials required to make a successful choice as follows:
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define count 0))
+(test-eval
+ '(let ((x (an-element-of '(a b c)))
+ (y (an-element-of '(a b c))))
+ (permanent-set! count (+ count 1))
+ (require (not (eq? x y)))
+ (list x y count))
+ '(a b 2))
+(test-eval 'try-again '(a c 3))
+
+;; What values would have been displayed if we had used set! here rather than permanent-set! ?
+
+;; if we had used set!, we would end up with (a b 1) and (a c 1). Count would always just be 1.
blob - /dev/null
blob + c431731203cc3cd7bc509b11e5f72316bd278155 (mode 644)
--- /dev/null
+++ ex4-51.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((permanent-assignment? exp)
+ (analyze-permanent-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+(define (analyze-permanent-assignment exp)
+ (let ((var (permanent-assignment-variable exp))
+ (vproc (analyze (permanent-assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc
+ env
+ (lambda (val val-fail)
+ (set-variable-value! var val env)
+ (succeed 'ok val-fail))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/permanent-assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (permanent-assignment? exp)
+ (tagged-list? exp 'permanent-set!))
+(define permanent-assignment-variable assignment-variable)
+(define permanent-assignment-value assignment-value)
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+;; Exercise 4.51. Implement a new kind of assignment called permanent-set! that is not undone upon failure. For example, we can choose two distinct elements from a list and count the number of trials required to make a successful choice as follows:
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define count 0))
+(test-eval
+ '(let ((x (an-element-of '(a b c)))
+ (y (an-element-of '(a b c))))
+ (permanent-set! count (+ count 1))
+ (require (not (eq? x y)))
+ (list x y count))
+'(a b 2))
+(print-eval 'try-again)
+
+;; What values would have been displayed if we had used set! here rather than permanent-set! ?
blob - /dev/null
blob + c65d16a823cbb009a23ba0c973a806c35c392bab (mode 644)
--- /dev/null
+++ ex4-52-2.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((permanent-assignment? exp)
+ (analyze-permanent-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+ ((if-fail? exp) (analyze-if-fail exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-if-fail exp)
+ (let ((dproc (analyze (if-fail-default exp)))
+ (aproc (analyze (if-fail-alternative exp))))
+ (lambda (env succeed fail)
+ (dproc env
+ (lambda (default-val default-fail)
+ (succeed default-val default-fail))
+ (lambda ()
+ (aproc env
+ (lambda (alt-val alt-fail)
+ (succeed alt-val alt-fail))
+ fail))))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+(define (analyze-permanent-assignment exp)
+ (let ((var (permanent-assignment-variable exp))
+ (vproc (analyze (permanent-assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc
+ env
+ (lambda (val val-fail)
+ (set-variable-value! var val env)
+ (succeed 'ok val-fail))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/permanent-assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (permanent-assignment? exp)
+ (tagged-list? exp 'permanent-set!))
+(define permanent-assignment-variable assignment-variable)
+(define permanent-assignment-value assignment-value)
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor/if-fail
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+(define (if-fail? exp)
+ (tagged-list? exp 'if-fail))
+(define (if-fail-default exp)
+ (cadr exp))
+(define (if-fail-alternative exp)
+ (caddr exp))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'even? even?)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+;; Exercise 4.51. Implement a new kind of assignment called permanent-set! that is not undone upon failure. For example, we can choose two distinct elements from a list and count the number of trials required to make a successful choice as follows:
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define count 0))
+(test-eval
+ '(let ((x (an-element-of '(a b c)))
+ (y (an-element-of '(a b c))))
+ (permanent-set! count (+ count 1))
+ (require (not (eq? x y)))
+ (list x y count))
+ '(a b 2))
+(test-eval 'try-again '(a c 3))
+
+;; What values would have been displayed if we had used set! here rather than permanent-set! ?
+
+;; if we had used set!, we would end up with (a b 1) and (a c 1). Count would always just be 1.
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 'all-odd)
+(test-eval 'try-again "No alternatives")
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5 8))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 8)
+(test-eval 'try-again "all-odd")
+(test-eval 'try-again "No alternatives")
+
+;; it could also be implemented as a syntactic transformation
+;; (if-fail <default> <alternative>) --> (amb <default> <alternative>)
+
+(define (if-fail->amb exp)
+ (make-amb (list (if-fail-default exp)
+ (if-fail-alternative exp))))
blob - /dev/null
blob + 103ead476d03eceddb235a0bd55faa513b6cf9cb (mode 644)
--- /dev/null
+++ ex4-52-2.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((permanent-assignment? exp)
+ (analyze-permanent-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+(define (analyze-permanent-assignment exp)
+ (let ((var (permanent-assignment-variable exp))
+ (vproc (analyze (permanent-assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc
+ env
+ (lambda (val val-fail)
+ (set-variable-value! var val env)
+ (succeed 'ok val-fail))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/permanent-assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (permanent-assignment? exp)
+ (tagged-list? exp 'permanent-set!))
+(define permanent-assignment-variable assignment-variable)
+(define permanent-assignment-value assignment-value)
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+;; Exercise 4.51. Implement a new kind of assignment called permanent-set! that is not undone upon failure. For example, we can choose two distinct elements from a list and count the number of trials required to make a successful choice as follows:
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define count 0))
+(test-eval
+ '(let ((x (an-element-of '(a b c)))
+ (y (an-element-of '(a b c))))
+ (permanent-set! count (+ count 1))
+ (require (not (eq? x y)))
+ (list x y count))
+ '(a b 2))
+(test-eval 'try-again '(a c 3))
+
+;; What values would have been displayed if we had used set! here rather than permanent-set! ?
+
+;; if we had used set!, we would end up with (a b 1) and (a c 1). Count would always just be 1.
+
blob - /dev/null
blob + 6a8ed26194a4846fa21aef83a0a35ca64dbfdd0f (mode 644)
--- /dev/null
+++ ex4-52-3.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((permanent-assignment? exp)
+ (analyze-permanent-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+;; ((if-fail? exp) (analyze-if-fail exp))
+ ((if-fail? exp) (analyze (if-fail->amb exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-if-fail exp)
+ (let ((dproc (analyze (if-fail-default exp)))
+ (aproc (analyze (if-fail-alternative exp))))
+ (lambda (env succeed fail)
+ (dproc env
+ succeed
+ (lambda ()
+ (aproc env succeed fail))))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+(define (analyze-permanent-assignment exp)
+ (let ((var (permanent-assignment-variable exp))
+ (vproc (analyze (permanent-assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc
+ env
+ (lambda (val val-fail)
+ (set-variable-value! var val env)
+ (succeed 'ok val-fail))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/permanent-assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (permanent-assignment? exp)
+ (tagged-list? exp 'permanent-set!))
+(define permanent-assignment-variable assignment-variable)
+(define permanent-assignment-value assignment-value)
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor/if-fail
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+(define (if-fail->amb exp)
+ (make-amb (list (if-fail-default exp)
+ (if-fail-alternative exp))))
+(define (if-fail? exp)
+ (tagged-list? exp 'if-fail))
+(define (if-fail-default exp)
+ (cadr exp))
+(define (if-fail-alternative exp)
+ (caddr exp))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'even? even?)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+;; Exercise 4.51. Implement a new kind of assignment called permanent-set! that is not undone upon failure. For example, we can choose two distinct elements from a list and count the number of trials required to make a successful choice as follows:
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define count 0))
+(test-eval
+ '(let ((x (an-element-of '(a b c)))
+ (y (an-element-of '(a b c))))
+ (permanent-set! count (+ count 1))
+ (require (not (eq? x y)))
+ (list x y count))
+ '(a b 2))
+(test-eval 'try-again '(a c 3))
+
+;; What values would have been displayed if we had used set! here rather than permanent-set! ?
+
+;; if we had used set!, we would end up with (a b 1) and (a c 1). Count would always just be 1.
+
+
+;; it could also be implemented as a syntactic transformation
+;; (if-fail <default> <alternative>) --> (amb <default> <alternative>)
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 'all-odd)
+(test-eval 'try-again "No alternatives")
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5 8))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 8)
+(test-eval 'try-again "all-odd")
+(test-eval 'try-again "No alternatives")
blob - /dev/null
blob + c65d16a823cbb009a23ba0c973a806c35c392bab (mode 644)
--- /dev/null
+++ ex4-52-3.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((permanent-assignment? exp)
+ (analyze-permanent-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+ ((if-fail? exp) (analyze-if-fail exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-if-fail exp)
+ (let ((dproc (analyze (if-fail-default exp)))
+ (aproc (analyze (if-fail-alternative exp))))
+ (lambda (env succeed fail)
+ (dproc env
+ (lambda (default-val default-fail)
+ (succeed default-val default-fail))
+ (lambda ()
+ (aproc env
+ (lambda (alt-val alt-fail)
+ (succeed alt-val alt-fail))
+ fail))))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+(define (analyze-permanent-assignment exp)
+ (let ((var (permanent-assignment-variable exp))
+ (vproc (analyze (permanent-assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc
+ env
+ (lambda (val val-fail)
+ (set-variable-value! var val env)
+ (succeed 'ok val-fail))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/permanent-assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (permanent-assignment? exp)
+ (tagged-list? exp 'permanent-set!))
+(define permanent-assignment-variable assignment-variable)
+(define permanent-assignment-value assignment-value)
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor/if-fail
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+(define (if-fail? exp)
+ (tagged-list? exp 'if-fail))
+(define (if-fail-default exp)
+ (cadr exp))
+(define (if-fail-alternative exp)
+ (caddr exp))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'even? even?)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+;; Exercise 4.51. Implement a new kind of assignment called permanent-set! that is not undone upon failure. For example, we can choose two distinct elements from a list and count the number of trials required to make a successful choice as follows:
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define count 0))
+(test-eval
+ '(let ((x (an-element-of '(a b c)))
+ (y (an-element-of '(a b c))))
+ (permanent-set! count (+ count 1))
+ (require (not (eq? x y)))
+ (list x y count))
+ '(a b 2))
+(test-eval 'try-again '(a c 3))
+
+;; What values would have been displayed if we had used set! here rather than permanent-set! ?
+
+;; if we had used set!, we would end up with (a b 1) and (a c 1). Count would always just be 1.
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 'all-odd)
+(test-eval 'try-again "No alternatives")
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5 8))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 8)
+(test-eval 'try-again "all-odd")
+(test-eval 'try-again "No alternatives")
+
+;; it could also be implemented as a syntactic transformation
+;; (if-fail <default> <alternative>) --> (amb <default> <alternative>)
+
+(define (if-fail->amb exp)
+ (make-amb (list (if-fail-default exp)
+ (if-fail-alternative exp))))
blob - /dev/null
blob + 23eb793258b8f7a97a2bb2d450709f9097f43965 (mode 644)
--- /dev/null
+++ ex4-52.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((permanent-assignment? exp)
+ (analyze-permanent-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+ ((if-fail? exp) (analyze-if-fail exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-if-fail exp)
+ (let ((dproc (analyze (if-default exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (dproc env
+ (lambda (default-val default-fail)
+ (succeed default-val default-fail))
+ (lambda ()
+ (aproc env
+ (lambda (alt-val alt-fail)
+ (succeed alt-val alt-fail))
+ fail))))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+(define (analyze-permanent-assignment exp)
+ (let ((var (permanent-assignment-variable exp))
+ (vproc (analyze (permanent-assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc
+ env
+ (lambda (val val-fail)
+ (set-variable-value! var val env)
+ (succeed 'ok val-fail))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/permanent-assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (permanent-assignment? exp)
+ (tagged-list? exp 'permanent-set!))
+(define permanent-assignment-variable assignment-variable)
+(define permanent-assignment-value assignment-value)
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor/if-fail
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+(define (if-fail? exp)
+ (tagged-list? exp 'if-fail))
+(define (if-default exp)
+ (cadr exp))
+(define (if-alternative exp)
+ (caddr exp))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define count 0))
+(test-eval
+ '(let ((x (an-element-of '(a b c)))
+ (y (an-element-of '(a b c))))
+ (permanent-set! count (+ count 1))
+ (require (not (eq? x y)))
+ (list x y count))
+ '(a b 2))
+(test-eval 'try-again '(a c 3))
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 'all-odd)
+(test-eval 'try-again "No alternatives")
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5 8))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 8)
+(test-eval 'try-again "No alternatives")
+
blob - /dev/null
blob + 23eb793258b8f7a97a2bb2d450709f9097f43965 (mode 644)
--- /dev/null
+++ ex4-52.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((permanent-assignment? exp)
+ (analyze-permanent-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+ ((if-fail? exp) (analyze-if-fail exp))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-if-fail exp)
+ (let ((dproc (analyze (if-default exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (dproc env
+ (lambda (default-val default-fail)
+ (succeed default-val default-fail))
+ (lambda ()
+ (aproc env
+ (lambda (alt-val alt-fail)
+ (succeed alt-val alt-fail))
+ fail))))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+(define (analyze-permanent-assignment exp)
+ (let ((var (permanent-assignment-variable exp))
+ (vproc (analyze (permanent-assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc
+ env
+ (lambda (val val-fail)
+ (set-variable-value! var val env)
+ (succeed 'ok val-fail))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/permanent-assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (permanent-assignment? exp)
+ (tagged-list? exp 'permanent-set!))
+(define permanent-assignment-variable assignment-variable)
+(define permanent-assignment-value assignment-value)
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor/if-fail
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+(define (if-fail? exp)
+ (tagged-list? exp 'if-fail))
+(define (if-default exp)
+ (cadr exp))
+(define (if-alternative exp)
+ (caddr exp))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define count 0))
+(test-eval
+ '(let ((x (an-element-of '(a b c)))
+ (y (an-element-of '(a b c))))
+ (permanent-set! count (+ count 1))
+ (require (not (eq? x y)))
+ (list x y count))
+ '(a b 2))
+(test-eval 'try-again '(a c 3))
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 'all-odd)
+(test-eval 'try-again "No alternatives")
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5 8))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 8)
+(test-eval 'try-again "No alternatives")
+
blob - /dev/null
blob + b08196dd773ac749f5ff5d03f1510924dfd667e5 (mode 644)
--- /dev/null
+++ ex4-53.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((permanent-assignment? exp)
+ (analyze-permanent-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+ ((if-fail? exp) (analyze-if-fail exp))
+;; ((if-fail? exp) (analyze (if-fail->amb exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-if-fail exp)
+ (let ((dproc (analyze (if-fail-default exp)))
+ (aproc (analyze (if-fail-alternative exp))))
+ (lambda (env succeed fail)
+ (dproc env
+ succeed
+ (lambda ()
+ (aproc env succeed fail))))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+(define (analyze-permanent-assignment exp)
+ (let ((var (permanent-assignment-variable exp))
+ (vproc (analyze (permanent-assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc
+ env
+ (lambda (val val-fail)
+ (set-variable-value! var val env)
+ (succeed 'ok val-fail))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/permanent-assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (permanent-assignment? exp)
+ (tagged-list? exp 'permanent-set!))
+(define permanent-assignment-variable assignment-variable)
+(define permanent-assignment-value assignment-value)
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor/if-fail
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+;; (define (if-fail->amb exp)
+;; (make-amb (list (if-fail-default exp)
+;; (if-fail-alternative exp))))
+(define (if-fail? exp)
+ (tagged-list? exp 'if-fail))
+(define (if-fail-default exp)
+ (cadr exp))
+(define (if-fail-alternative exp)
+ (caddr exp))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'even? even?)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define count 0))
+(test-eval
+ '(let ((x (an-element-of '(a b c)))
+ (y (an-element-of '(a b c))))
+ (permanent-set! count (+ count 1))
+ (require (not (eq? x y)))
+ (list x y count))
+ '(a b 2))
+(test-eval 'try-again '(a c 3))
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 'all-odd)
+(test-eval 'try-again "No alternatives")
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5 8))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 8)
+(test-eval 'try-again "all-odd")
+(test-eval 'try-again "No alternatives")
+
+;; Exercise 4.53. With permanent-set! as described in exercise 4.51 and if-fail as in exercise 4.52, what will be the result of evaluating
+
+(geval
+ '(define (prime? n)
+ (= n (smallest-divisor n))))
+(geval
+ '(define (smallest-divisor n)
+ (find-divisor n 2)))
+(geval
+ '(define (square x) (* x x)))
+(geval
+ '(define (find-divisor n test-divisor)
+ (cond ((> (square test-divisor) n) n)
+ ((divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1))))))
+(geval
+ '(define (divides? a b)
+ (= (remainder b a) 0)))
+
+
+(geval
+ '(define (prime-sum-pair list1 list2)
+ (let ((a (an-element-of list1))
+ (b (an-element-of list2)))
+ (require (prime? (+ a b)))
+ (list a b))))
+
+(test-eval
+ '(let ((pairs '()))
+ (if-fail
+ (let ((p (prime-sum-pair '(1 3 5 8)
+ '(20 35 110))))
+ (permanent-set! pairs (cons p pairs))
+ (amb))
+ pairs))
+ '((8 35) (3 110) (3 20)))
+
+
blob - /dev/null
blob + 6a8ed26194a4846fa21aef83a0a35ca64dbfdd0f (mode 644)
--- /dev/null
+++ ex4-53.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((permanent-assignment? exp)
+ (analyze-permanent-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+;; ((if-fail? exp) (analyze-if-fail exp))
+ ((if-fail? exp) (analyze (if-fail->amb exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-if-fail exp)
+ (let ((dproc (analyze (if-fail-default exp)))
+ (aproc (analyze (if-fail-alternative exp))))
+ (lambda (env succeed fail)
+ (dproc env
+ succeed
+ (lambda ()
+ (aproc env succeed fail))))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+(define (analyze-permanent-assignment exp)
+ (let ((var (permanent-assignment-variable exp))
+ (vproc (analyze (permanent-assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc
+ env
+ (lambda (val val-fail)
+ (set-variable-value! var val env)
+ (succeed 'ok val-fail))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/permanent-assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (permanent-assignment? exp)
+ (tagged-list? exp 'permanent-set!))
+(define permanent-assignment-variable assignment-variable)
+(define permanent-assignment-value assignment-value)
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor/if-fail
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+(define (if-fail->amb exp)
+ (make-amb (list (if-fail-default exp)
+ (if-fail-alternative exp))))
+(define (if-fail? exp)
+ (tagged-list? exp 'if-fail))
+(define (if-fail-default exp)
+ (cadr exp))
+(define (if-fail-alternative exp)
+ (caddr exp))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'even? even?)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+;; Exercise 4.51. Implement a new kind of assignment called permanent-set! that is not undone upon failure. For example, we can choose two distinct elements from a list and count the number of trials required to make a successful choice as follows:
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define count 0))
+(test-eval
+ '(let ((x (an-element-of '(a b c)))
+ (y (an-element-of '(a b c))))
+ (permanent-set! count (+ count 1))
+ (require (not (eq? x y)))
+ (list x y count))
+ '(a b 2))
+(test-eval 'try-again '(a c 3))
+
+;; What values would have been displayed if we had used set! here rather than permanent-set! ?
+
+;; if we had used set!, we would end up with (a b 1) and (a c 1). Count would always just be 1.
+
+
+;; it could also be implemented as a syntactic transformation
+;; (if-fail <default> <alternative>) --> (amb <default> <alternative>)
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 'all-odd)
+(test-eval 'try-again "No alternatives")
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5 8))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 8)
+(test-eval 'try-again "all-odd")
+(test-eval 'try-again "No alternatives")
blob - /dev/null
blob + b95eafa3159ceb97387dde93e811d167fa6db669 (mode 644)
--- /dev/null
+++ ex4-54.scm
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((permanent-assignment? exp)
+ (analyze-permanent-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+ ((require? exp) (analyze-require exp))
+ ((if-fail? exp) (analyze-if-fail exp))
+;; ((if-fail? exp) (analyze (if-fail->amb exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-if-fail exp)
+ (let ((dproc (analyze (if-fail-default exp)))
+ (aproc (analyze (if-fail-alternative exp))))
+ (lambda (env succeed fail)
+ (dproc env
+ succeed
+ (lambda ()
+ (aproc env succeed fail))))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+(define (analyze-permanent-assignment exp)
+ (let ((var (permanent-assignment-variable exp))
+ (vproc (analyze (permanent-assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc
+ env
+ (lambda (val val-fail)
+ (set-variable-value! var val env)
+ (succeed 'ok val-fail))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+(define (analyze-require exp)
+ (let ((pproc (analyze (require-predicate exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ (lambda (pred-value fail2)
+ (if (false? pred-value)
+ (fail2)
+ (succeed 'ok fail2)))
+ fail))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb/require
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+(define (require? exp) (tagged-list? exp 'require))
+(define (require-predicate exp) (cadr exp))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/permanent-assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (permanent-assignment? exp)
+ (tagged-list? exp 'permanent-set!))
+(define permanent-assignment-variable assignment-variable)
+(define permanent-assignment-value assignment-value)
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor/if-fail
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+;; (define (if-fail->amb exp)
+;; (make-amb (list (if-fail-default exp)
+;; (if-fail-alternative exp))))
+(define (if-fail? exp)
+ (tagged-list? exp 'if-fail))
+(define (if-fail-default exp)
+ (cadr exp))
+(define (if-fail-alternative exp)
+ (caddr exp))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'even? even?)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+;; (geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define count 0))
+(test-eval
+ '(let ((x (an-element-of '(a b c)))
+ (y (an-element-of '(a b c))))
+ (permanent-set! count (+ count 1))
+ (require (not (eq? x y)))
+ (list x y count))
+ '(a b 2))
+(test-eval 'try-again '(a c 3))
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 'all-odd)
+(test-eval 'try-again "No alternatives")
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5 8))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 8)
+(test-eval 'try-again "all-odd")
+(test-eval 'try-again "No alternatives")
+
+;; Exercise 4.53. With permanent-set! as described in exercise 4.51 and if-fail as in exercise 4.52, what will be the result of evaluating
+
+(geval
+ '(define (prime? n)
+ (= n (smallest-divisor n))))
+(geval
+ '(define (smallest-divisor n)
+ (find-divisor n 2)))
+(geval
+ '(define (square x) (* x x)))
+(geval
+ '(define (find-divisor n test-divisor)
+ (cond ((> (square test-divisor) n) n)
+ ((divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1))))))
+(geval
+ '(define (divides? a b)
+ (= (remainder b a) 0)))
+
+
+(geval
+ '(define (prime-sum-pair list1 list2)
+ (let ((a (an-element-of list1))
+ (b (an-element-of list2)))
+ (require (prime? (+ a b)))
+ (list a b))))
+
+(test-eval
+ '(let ((pairs '()))
+ (if-fail
+ (let ((p (prime-sum-pair '(1 3 5 8)
+ '(20 35 110))))
+ (permanent-set! pairs (cons p pairs))
+ (amb))
+ pairs))
+ '((8 35) (3 110) (3 20)))
+
+;; Exercise 4.54. If we had not realized that require could be implemented as an ordinary procedure that uses amb, to be defined by the user as part of a nondeterministic program, we would have had to implement it as a special form. This would require syntax procedures
+
+;; (define (require? exp) (tagged-list? exp 'require))
+;; (define (require-predicate exp) (cadr exp))
+
+;; and a new clause in the dispatch in analyze
+
+;; ((require? exp) (analyze-require exp))
+
+;; as well the procedure analyze-require that handles require expressions. Complete the following definition of analyze-require.
+
+;; (define (analyze-require exp)
+;; (let ((pproc (analyze (require-predicate exp))))
+;; (lambda (env succeed fail)
+;; (pproc env
+;; (lambda (pred-value fail2)
+;; (if <??>
+;; <??>
+;; (succeed 'ok fail2)))
+;; fail))))
+
blob - /dev/null
blob + b08196dd773ac749f5ff5d03f1510924dfd667e5 (mode 644)
--- /dev/null
+++ ex4-54.scm~
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((permanent-assignment? exp)
+ (analyze-permanent-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((and? exp) (analyze (and->if exp)))
+ ((or? exp) (analyze (or->if exp)))
+ ((not? exp) (analyze (not->if exp)))
+ ((xor? exp) (analyze (xor->or-and-not exp)))
+ ((lambda? exp) (analyze-lambda exp))
+ ((let? exp) (analyze (let->combination exp)))
+ ((let*? exp) (analyze (let*->nested-lets exp)))
+ ((named-let? exp) (analyze (named-let->combination exp)))
+ ((letrec? exp) (analyze (letrec->let exp)))
+ ((do? exp) (analyze (do->combination exp)))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
+ ((amb? exp) (analyze-amb exp))
+ ((ramb? exp) (analyze (ramb->amb exp)))
+ ((if-fail? exp) (analyze-if-fail exp))
+;; ((if-fail? exp) (analyze (if-fail->amb exp)))
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
+
+
+;; analyzing procedures
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env)
+ fail)))
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
+;; (bproc (analyze-sequence (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-procedure vars bproc env)
+ fail))))
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env succeed fail)
+ (pproc env
+ ;; success continuation for evaluating the predicate
+ ;; to obtain pred-value
+ (lambda (pred-value fail2)
+ (if (true? pred-value)
+ (cproc env succeed fail2)
+ (aproc env succeed fail2)))
+ ;; failure continuation for evaluating the predicate
+ fail))))
+(define (analyze-if-fail exp)
+ (let ((dproc (analyze (if-fail-default exp)))
+ (aproc (analyze (if-fail-alternative exp))))
+ (lambda (env succeed fail)
+ (dproc env
+ succeed
+ (lambda ()
+ (aproc env succeed fail))))))
+(define (analyze-sequence exps)
+ (define (sequentially a b)
+ (lambda (env succeed fail)
+ (a env
+ ;; success continuation for calling a
+ (lambda (a-value fail2)
+ (b env succeed fail2))
+ ;; failure continuation for calling a
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (let ((procs (map analyze exps)))
+ (if (null? procs)
+ (error "Empty sequence -- ANALYZE"))
+ (loop (car procs) (cdr procs))))
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2)
+ (define-variable! var val env)
+ (succeed 'ok fail2))
+ fail))))
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (val fail2) ; *1*
+ (let ((old-value
+ (lookup-variable-value var env)))
+ (set-variable-value! var val env)
+ (succeed 'ok
+ (lambda () ; *2*
+ (set-variable-value! var
+ old-value
+ env)
+ (fail2)))))
+ fail))))
+(define (analyze-permanent-assignment exp)
+ (let ((var (permanent-assignment-variable exp))
+ (vproc (analyze (permanent-assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc
+ env
+ (lambda (val val-fail)
+ (set-variable-value! var val env)
+ (succeed 'ok val-fail))
+ fail))))
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc fail2)
+ (get-args aprocs
+ env
+ (lambda (args fail3)
+ (execute-application
+ proc args succeed fail3))
+ fail2))
+ fail))))
+(define (get-args aprocs env succeed fail)
+ (if (null? aprocs)
+ (succeed '() fail)
+ ((car aprocs) env
+ ;; success continuation for this aproc
+ (lambda (arg fail2)
+ (get-args (cdr aprocs)
+ env
+ ;; success continuation for recursive
+ ;; call to get-args
+ (lambda (args fail3)
+ (succeed (cons arg args)
+ fail3))
+ fail2))
+ fail)))
+
+(define (analyze-amb exp)
+ (let ((cprocs (map analyze (amb-choices exp))))
+ (lambda (env succeed fail)
+ (define (try-next choices)
+ (if (null? choices)
+ (fail)
+ ((car choices) env
+ succeed
+ (lambda ()
+ (try-next (cdr choices))))))
+ (try-next cprocs))))
+
+
+
+
+
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; amb/ramb
+(define (amb? exp) (tagged-list? exp 'amb))
+(define (amb-choices exp) (cdr exp))
+(define (make-amb choices)
+ (cons 'amb choices))
+
+(define (ramb? exp)
+ (tagged-list? exp 'ramb))
+(define (ramb->amb exp)
+ (make-amb (shuffle (amb-choices exp))))
+
+(define (shuffle items)
+ (if (null? items)
+ '()
+ (let ((first (list-ref items (random (length items)))))
+ (cons first
+ (shuffle (remove (lambda (i) (eq? first i))
+ items))))))
+
+
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/permanent-assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (make-assignment var val)
+ (list 'set! var val))
+(define (permanent-assignment? exp)
+ (tagged-list? exp 'permanent-set!))
+(define permanent-assignment-variable assignment-variable)
+(define permanent-assignment-value assignment-value)
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (make-definition var val)
+ `(define ,var ,val))
+
+;; if/and/or/not/xor/if-fail
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (and->if exp)
+ (define (expand-clauses clauses)
+ (cond ((null? clauses) 'true)
+ ((null? (cdr clauses)) (car clauses))
+ (else (make-if (car clauses)
+ (expand-clauses (cdr clauses))
+ 'false))))
+ (expand-clauses (and-clauses exp)))
+(define (or->if exp)
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (make-if (car clauses)
+ (car clauses)
+ (expand-clauses (cdr clauses)))))
+ (expand-clauses (or-clauses exp)))
+(define (not? exp)
+ (tagged-list? exp 'not))
+(define (not->if exp)
+ `(if ,(cadr exp) false true))
+(define (xor? exp)
+ (tagged-list? exp 'xor))
+(define (xor->or-and-not exp)
+ (let ((pred-1 (cadr exp))
+ (pred-2 (caddr exp)))
+ `(or (and ,pred-1 (not ,pred-2))
+ (and (not ,pred-1) ,pred-2))))
+;; (define (if-fail->amb exp)
+;; (make-amb (list (if-fail-default exp)
+;; (if-fail-alternative exp))))
+(define (if-fail? exp)
+ (tagged-list? exp 'if-fail))
+(define (if-fail-default exp)
+ (cadr exp))
+(define (if-fail-alternative exp)
+ (caddr exp))
+
+;; lambda/let/let*/letrec
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+v (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (letrec? exp)
+ (tagged-list? exp 'letrec))
+
+(define (letrec-vars exp)
+ (map car (cadr exp)))
+(define (letrec-vals exp)
+ (map cadr (cadr exp)))
+(define (letrec-body exp)
+ (cddr exp))
+(define (letrec->let exp)
+ (let* ((vars (letrec-vars exp))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (letrec-vals exp))
+ (assignments (map (lambda (var val)
+ (make-assignment var val))
+ vars
+ vals))
+ (body (letrec-body exp)))
+ (make-let vars
+ unassigneds
+ (append assignments body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (scan-out-defines body)
+ (let* ((definitions (filter definition? body))
+ (vars (map definition-variable definitions))
+ (unassigneds (map (lambda (var) ''*unassigned*)
+ vars))
+ (vals (map definition-value definitions))
+ (assignments
+ (map (lambda (var val)
+ (make-assignment var val))
+ vars vals))
+ (exps (remove definition? body)))
+ (if (null? definitions)
+ body
+ (list
+ (make-let vars
+ unassigneds
+ (append assignments exps))))))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+;; (let ((val (car vals)))
+;; (if (eq? val '*unassigned*)
+;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+;; val)))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; (define (remove-binding-from-frame! var frame)
+;; (define (scan vars vals)
+;; (cond ((null? (cdr vars))
+;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
+;; ((eq? var (cadr vars))
+;; (set-cdr! vars (cddr vars))
+;; (set-cdr! vals (cddr vals)))
+;; (else (scan (cdr vars) (cdr vals)))))
+;; (let ((vars (frame-variables frame))
+;; (vals (frame-values frame)))
+;; (if (eq? var (car vars))
+;; (begin (set-car! frame (cdr vars))
+;; (set-cdr! frame (cdr vals)))
+;; (scan vars vals))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'caddr caddr)
+ (list 'cdddr cdddr)
+ (list 'cons cons)
+ (list 'list list)
+ (list 'null? null?)
+ (list 'pair? pair?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'even? even?)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'member member)
+ (list 'memq memq)
+ (list 'display display)
+ (list 'error error)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply
+ (primitive-implementation proc) args))
+
+;; execute application
+
+(define (execute-application proc args succeed fail)
+ (cond ((primitive-procedure? proc)
+ (succeed (apply-primitive-procedure proc args)
+ fail))
+ ((compound-procedure? proc)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ (else
+ (error
+ "Unknown procedure type -- EXECUTE-APPLICATION"
+ proc))))
+
+
+;; driver-loop
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define input-prompt ";;; Amb-Eval input:")
+(define output-prompt ";;; Amb-Eval value:")
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (ambeval input
+ the-global-environment
+ ;; ambeval success
+ (lambda (val next-alternative)
+ (announce-output output-prompt)
+ (user-print val)
+ (internal-loop next-alternative))
+ ;; ambeval failure
+ (lambda ()
+ (announce-output
+ ";;; There are no more values of")
+ (user-print input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (newline)
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define try-again
+ (lambda ()
+ "No current problem"))
+(define (geval exp) ;; eval globally
+ (if (eq? exp 'try-again)
+ (try-again)
+ (ambeval exp
+ the-global-environment
+ (lambda (val next-alternative)
+ (set! try-again next-alternative)
+ val)
+ (lambda ()
+ (set! try-again
+ (lambda ()
+ "No current problem"))
+ "No alternatives"))))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+(define (print-eval exp)
+ (user-print (geval exp)))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y)))))
+(geval
+ '(define (list-ref items n)
+ (if (= n 0)
+ (car items)
+ (list-ref (cdr items) (- n 1)))))
+(geval
+ '(define (fold-left f init seq)
+ (if (null? seq)
+ init
+ (fold-left f
+ (f init (car seq))
+ (cdr seq)))))
+(geval
+ '(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high)))))
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+(geval
+ '(define (map-2 proc l1 l2)
+ (if (null? l1)
+ '()
+ (cons (proc (car l1) (car l2))
+ (map-2 proc (cdr l1) (cdr l2))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; ;; ;; all special forms
+;; (test-eval '(begin 5 6) 6)
+;; (test-eval '10 10)
+;; (geval '(define x 3))
+;; (test-eval 'x 3)
+;; (test-eval '(set! x -25) 'ok)
+;; (test-eval 'x -25)
+;; (geval '(define z (lambda (x y) (+ x (* x y)))))
+;; (test-eval '(z 3 4) 15)
+;; (test-eval '(cond ((= x -2) 'x=-2)
+;; ((= x -25) 'x=-25)
+;; (else 'failed))
+;; 'x=-25)
+;; (test-eval '(if true false true) false)
+
+;; (test-eval
+;; '(let ((x 4) (y 7))
+;; (+ x y (* x y)))
+;; (+ 4 7 (* 4 7)))
+
+
+;; ;; and/or
+;; (geval '(define x (+ 3 8)))
+;; (test-eval '(and 0 true x) 11)
+;; (test-eval '(and 0 true x false) false)
+;; (test-eval '(and 0 true x (set! x -2) false) false)
+;; (test-eval 'x -2)
+;; (test-eval '(and 0 true x false (set! x -5)) false)
+;; (test-eval 'x -2)
+;; (test-eval '(or false (set! x 25)) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
+;; (test-eval 'x 2)
+;; (test-eval '(or false (set! x 25) true false) 'ok)
+;; (test-eval 'x 25)
+;; (test-eval '(or ((lambda (x) x) 5)) 5)
+;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
+;; (newline)
+;; (display "Failure expected")
+;; (newline)
+
+;; ;; cond
+
+;; (test-eval
+;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+;; 2)
+
+;; (test-eval
+;; '(cond ((= 3 4) 'not-true)
+;; ((= (* 2 4) 3) 'also-false)
+;; ((map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 4 1 9))
+;; =>
+;; (lambda (x)
+;; (accumulate + 0 x)))
+;; (else 'never-reach))
+;; 118)
+;; ;; '(6 20 2 90)
+
+
+;; ;; procedure definition and application
+;; (geval
+;; '(define (factorial n)
+;; (if (= n 0)
+;; 1
+;; (* n (factorial (- n 1))))))
+;; (test-eval '(factorial 5) 120)
+
+;; ;; map
+
+;; (test-eval
+;; '(map (lambda (x)
+;; (* x (+ x 1)))
+;; '(2 1 4 2 8 3))
+;; '(6 2 20 6 72 12))
+;; ;; accumulate
+
+;; (test-eval
+;; '(accumulate + 0 '(1 2 3 4 5))
+;; 15)
+
+;; ;; make-let
+;; (test-eval
+;; (make-let '(x y) '(3 5) '((+ x y)))
+;; 8)
+;; (test-eval
+;; '(let ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let ((x 3))
+;; x)
+;; 3)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 5))
+;; (+ x y))
+;; 8)
+;; (test-eval
+;; '(let ((x 3)
+;; (y 2))
+;; (+ (let ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 4 3) 3 2))
+;; (test-eval
+;; '(let ((x 6)
+;; (y (let ((x 2))
+;; (+ x 3)))
+;; (z (let ((a (* 3 2)))
+;; (+ a 3))))
+;; (+ x y z))
+;; (+ 6 5 9))
+
+
+;; ;; let*
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 2))
+;; (z (+ x y 5)))
+;; (* x z))
+;; 39)
+
+;; (test-eval
+;; '(let* ()
+;; 5)
+;; 5)
+;; (test-eval
+;; '(let* ((x 3))
+;; (let* ((y 5))
+;; (+ x y)))
+;; 8)
+
+;; (test-eval
+;; '(let* ((x 3)
+;; (y (+ x 1)))
+;; (+ (let* ((x (+ y 2))
+;; (y x))
+;; (* x y))
+;; x y))
+;; (+ (* 6 6) 3 4))
+;; (test-eval
+;; '(let* ((x 6)
+;; (y (let* ((x 2)
+;; (a (let* ((x (* 3 x)))
+;; (+ x 2))))
+;; (+ x a)))
+;; (z (+ x y)))
+;; (+ x y z))
+;; 32)
+
+;; ;; named-let
+
+;; (test-eval
+;; '(let eight ()
+;; 5
+;; 7
+;; 8)
+;; 8)
+;; (test-eval
+;; '(let loop ((count 0))
+;; (if (= 100 count)
+;; count
+;; (loop (+ count 1))))
+;; 100)
+;; (geval
+;; '(define (prime? x)
+;; (let prime-iter ((i 2))
+;; (cond ((> (* i i) x) true)
+;; ((= (remainder x i) 0) false)
+;; (else (prime-iter (+ i 1)))))))
+;; (test-eval
+;; '(let primes ((x 2)
+;; (n 20))
+;; (cond ((= n 0) '())
+;; ((prime? x)
+;; (cons x
+;; (primes (+ x 1) (- n 1))))
+;; (else (primes (+ x 1) n))))
+;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+;; (geval
+;; '(define (fib n)
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))))
+;; (test-eval '(fib 19) 4181)
+
+;; ;; do-loop
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(do ()
+;; (true))
+;; true)
+;; (test-eval
+;; '(do ()
+;; (true 5))
+;; 5)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ()
+;; ((= y 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+
+;; (test-eval
+;; '(do ((y '(1 2 3 4)))
+;; ((null? y))
+;; (set! y (cdr y)))
+;; true)
+;; (test-eval
+;; '(let ((y 0))
+;; (do ((x 0 (+ x 1)))
+;; ((= x 5) y)
+;; (set! y (+ y 1))))
+;; 5)
+;; (test-eval
+;; '(let ((x '(1 3 5 7 9)))
+;; (do ((x x (cdr x))
+;; (sum 0 (+ sum (car x))))
+;; ((null? x) sum)))
+;; 25)
+;; (test-eval
+;; '(let ((z '()))
+;; (do ((x '(1 2 3 4) (cdr x))
+;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
+;; ((null? x) y x z)
+;; (set! z (cons (car x) z))))
+;; '(4 3 2 1))
+
+
+
+;; ;; make-unbound!
+;; ;; broken now due to scan-out-defines
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (* x x)))
+;; ;; 9)
+
+;; ;; (test-eval
+;; ;; '(let ((x 3))
+;; ;; (let ((x 5))
+;; ;; (define y x)
+;; ;; (make-unbound! x)
+;; ;; (* y x)))
+;; ;; 15)
+
+;; ;; (test-eval
+;; ;; '(let ((y -1) (x 3))
+;; ;; (let ((y 0.5) (x 5))
+;; ;; (define a x)
+;; ;; (define b y)
+;; ;; (make-unbound! x)
+;; ;; (make-unbound! y)
+;; ;; (* a b x y)))
+;; ;; (* 5 3 -1 0.5))
+
+;; ;; (test-eval
+;; ;; '(let ((x 3) (y 4))
+;; ;; (let ((x 5))
+;; ;; (make-unbound! x)
+;; ;; (+ x 4)))
+;; ;; 7)
+
+;; ;; (test-eval
+;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
+;; ;; (make-unbound! b)
+;; ;; (+ a c d))
+;; ;; (+ 1 3 4))
+
+;; ;; (test-eval
+;; ;; '(let ((x 4) (y 5))
+;; ;; (let ((a 1) (b 2) (c 3))
+;; ;; (let ((x (+ a b)) (y (+ c a)))
+;; ;; (make-unbound! x)
+;; ;; (let ((a x) (b (+ x y)))
+;; ;; (define z b)
+;; ;; (make-unbound! b)
+;; ;; (* (+ a z)
+;; ;; (+ a b y))))))
+;; ;; (* (+ 4 8)
+;; ;; (+ 4 2 4)))
+
+;; ;; x 3 -- y 4
+;; ;; x 4 -- y 4
+;; ;; a 4 -- b 4
+;; ;; a 4 -- b 2
+
+;; ;; scan-out-defines
+
+;; (geval
+;; '(define (f x)
+;; (define (even? n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1))))
+;; (define (odd? n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))
+;; (even? x)))
+;; (test-eval '(f 5) false)
+;; (test-eval '(f 10) true)
+
+;; ;; (geval
+;; ;; '(let ((x 5))
+;; ;; (define y x)
+;; ;; (define x 3)
+;; ;; (+ x y)))
+;; ;; signal an error because x is undefined if variables are scanned out
+
+;; ;; letrec
+
+;; (geval
+;; '(define (f x)
+;; (letrec ((even?
+;; (lambda (n)
+;; (if (= n 0)
+;; true
+;; (odd? (- n 1)))))
+;; (odd?
+;; (lambda (n)
+;; (if (= n 0)
+;; false
+;; (even? (- n 1))))))
+;; (even? x))))
+;; (test-eval '(f 11) false)
+;; (test-eval '(f 16) true)
+
+;; (test-eval
+;; '(letrec ((fact
+;; (lambda (n)
+;; (if (= n 1)
+;; 1
+;; (* n (fact (- n 1)))))))
+;; (fact 10))
+;; 3628800)
+
+;; amb
+(geval '(define (require p) (if (not p) (amb))))
+
+;; (test-eval '(amb 1 2 3) 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 3)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval 'try-again "No current problem")
+;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
+;; 1)
+;; (test-eval 'try-again 2)
+;; (test-eval 'try-again 'a)
+;; (test-eval 'try-again 'b)
+;; (test-eval 'try-again "No alternatives")
+;; (test-eval '(require false) "No alternatives")
+;; (test-eval '(require true) false)
+
+
+(geval
+ '(define (an-integer-between low high)
+ (require (<= low high))
+ (amb low (an-integer-between (+ low 1) high))))
+
+(geval
+ '(define (a-pythagorean-triple-between low high)
+ (let ((i (an-integer-between low high)))
+ (let ((j (an-integer-between i high)))
+ (let ((k (an-integer-between j high)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))))
+
+;; (test-eval
+;; '(a-pythagorean-triple-between 1 20)
+;; '(3 4 5))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(8 15 17))
+;; (test-eval 'try-again '(9 12 15))
+
+(geval
+ '(define (an-integer-starting-from low)
+ (amb low (an-integer-starting-from (+ low 1)))))
+
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((k (an-integer-starting-from low))
+ (i (an-integer-between low k))
+ (j (an-integer-between i k)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+
+;; (test-eval '(pythagorean-triples-starting-from 1)
+;; '(3 4 5))
+;; (test-eval 'try-again '(6 8 10))
+;; (test-eval 'try-again '(5 12 13))
+;; (test-eval 'try-again '(9 12 15))
+;; (test-eval 'try-again '(8 15 17))
+
+(geval
+ '(define (next-triplet trp)
+ (let ((i (car trp))
+ (j (cadr trp))
+ (k (caddr trp)))
+ (cond ((= i j k) (list 1 1 (+ k 1)))
+ ((= j k) (list (+ i 1) (+ i 1) k))
+ (else (list i (+ j 1) k))))))
+(geval
+ '(define (triplet-starting-from trp)
+ (amb trp (triplet-starting-from (next-triplet trp)))))
+(geval
+ '(define (pythagorean-triples-starting-from low)
+ (let* ((triplet (triplet-starting-from (list low low low)))
+ (i (car triplet))
+ (j (cadr triplet))
+ (k (caddr triplet)))
+ (require (= (+ (* i i) (* j j)) (* k k)))
+ (list i j k))))
+(geval
+ '(define (distinct? items)
+ (cond ((null? items) true)
+ ((null? (cdr items)) true)
+ ((member (car items) (cdr items)) false)
+ (else (distinct? (cdr items))))))
+
+(geval
+ '(define (an-element-of items)
+ (require (not (null? items)))
+ (amb (car items) (an-element-of (cdr items)))))
+
+(geval
+ '(define count 0))
+(test-eval
+ '(let ((x (an-element-of '(a b c)))
+ (y (an-element-of '(a b c))))
+ (permanent-set! count (+ count 1))
+ (require (not (eq? x y)))
+ (list x y count))
+ '(a b 2))
+(test-eval 'try-again '(a c 3))
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 'all-odd)
+(test-eval 'try-again "No alternatives")
+
+(test-eval
+ '(if-fail (let ((x (an-element-of '(1 3 5 8))))
+ (require (even? x))
+ x)
+ 'all-odd)
+ 8)
+(test-eval 'try-again "all-odd")
+(test-eval 'try-again "No alternatives")
+
+;; Exercise 4.53. With permanent-set! as described in exercise 4.51 and if-fail as in exercise 4.52, what will be the result of evaluating
+
+(geval
+ '(define (prime? n)
+ (= n (smallest-divisor n))))
+(geval
+ '(define (smallest-divisor n)
+ (find-divisor n 2)))
+(geval
+ '(define (square x) (* x x)))
+(geval
+ '(define (find-divisor n test-divisor)
+ (cond ((> (square test-divisor) n) n)
+ ((divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1))))))
+(geval
+ '(define (divides? a b)
+ (= (remainder b a) 0)))
+
+
+(geval
+ '(define (prime-sum-pair list1 list2)
+ (let ((a (an-element-of list1))
+ (b (an-element-of list2)))
+ (require (prime? (+ a b)))
+ (list a b))))
+
+(test-eval
+ '(let ((pairs '()))
+ (if-fail
+ (let ((p (prime-sum-pair '(1 3 5 8)
+ '(20 35 110))))
+ (permanent-set! pairs (cons p pairs))
+ (amb))
+ pairs))
+ '((8 35) (3 110) (3 20)))
+
+
blob - /dev/null
blob + cd5ccb12c72c35ad7386a730633d7083ec0eb67a (mode 644)
--- /dev/null
+++ ex4-55.scm
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (myforce delayed-object)
+ (delayed-object))
+
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (display " -- "))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+;; Exercise 4.55. Give simple queries that retrieve the following information from the data base:
+
+;; a. all people supervised by Ben Bitdiddle;
+
+(eval-display-query '(supervisor ?employee (Bitdiddle Ben)))
+
+;;b. the names and jobs of all people in the accounting division;
+
+(eval-display-query '(job ?x (accounting . ?title)))
+
+;;c. the names and addresses of all people who live in Slumerville.
+
+(eval-display-query '(address ?person (Slumerville . ?rest)))
blob - /dev/null
blob + f7afff85bd3e0f795e2c5b778865f578a5fc70ac (mode 644)
--- /dev/null
+++ ex4-55.scm~
+query-driver-loop
+(define input-prompt ";;; Query Input: ")
+(define output-prompt ";;; Query Output: ")
+(define (query-driver-loop)
+ (print-output input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-assertion-or-rule! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (print-output output-prompt)
+ (newline)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate
+ q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream the-empty-frame))))
+ (query-driver-loop)))))
+
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((symbol? exp) (proc exp))
+ ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ (else exp)))
+(define (expand-question-mark exp)
+ (let ((chars (symbol->string exp)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ exp)))
+(define (contract-question-mark exp)
+ (string->symbol
+ (string-append
+ "?"
+ (if (number? (cadr exp))
+ (string-append
+ (symbol->string (caddr exp))
+ "-"
+ (number->string (cadr exp)))
+ (symbol->string (cadr exp))))))
+
+(define (instantiate pat frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp))
+ (copy (cdr exp))))
+ (else exp)))
+ (copy pat))
+
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression -- TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression -- CONTENTS" exp)))
+(define (add-assertion-or-rule! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES
+ (cons-stream rule old-rules))
+ 'ok))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let* ((key (index-key-of pattern))
+ (current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule current-rule-stream))))))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let* ((key (index-key-of assertion))
+ (current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion current-assertion-stream)))))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define (index-key-of pattern)
+ (let ((key (car pattern)))
+ (if (var? key) '? key)))
+(define (indexable? pattern)
+ (or (constant-symbol? (car pattern))
+ (var? (car pattern))))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp)
+ (symbol? exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (make-binding var val)
+ (cons var val))
+(define (extend var val frame)
+ (cons (make-binding var val) frame))
+(define (binding-in-frame var frame)
+ (assoc var frame))
+(define the-empty-frame '())
+(define (conclusion rule)
+ (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjuncts? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts) frame-stream))))
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjuncts? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts) frame-stream)))))
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null?
+ (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'and 'qeval conjoin)
+(put 'or 'qeval disjoin)
+(put 'not 'qeval negate)
+(put 'lisp-value 'qeval lisp-value)
+(put 'always-true 'qeval always-true)
+
+(define (empty-conjuncts? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjuncts? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed
+ (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed
+ (stream-cdr s1)
+ delayed-s2))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream s)
+ (if (stream-null? s)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car s)
+ (delay (flatten-stream (stream-cdr s))))))
+
+(define (simple-query query frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query frame)
+ (delay (apply-rules query frame))))
+ frame-stream))
+
+(define (find-assertions pattern frame)
+ (stream-flatmap
+ (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion dat pat frame)
+ (let ((match-result
+ (pattern-match dat pat frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+
+(define (extend-if-consistent var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) val frame)
+ (extend var val frame))))
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (use-index? pattern)
+ (constant-symbol? (car pattern)))
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+
+(define (apply-rules pattern frame)
+ (stream-flatmap
+ (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule pattern frame)
+ (let* ((clean-rule (rename-variables-in rule))
+ (unify-result
+ (unify-match pattern
+ (conclusion clean-rule)
+ frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result)))))
+
+;; review code here
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame))
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ ...)
+(define (depends-on? exp var frame)
+ ...)
+(define (rename-variables-in rule)
+ ...)
+
+(? x) <-> (? 3 x)
blob - /dev/null
blob + 67dd79ec55a026e887ebf668f35ce848953d1b44 (mode 644)
--- /dev/null
+++ ex4-56.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (display-stream (eval-query query))
+ (let ((list (car expected)))
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+ (newline)
+ (display query)
+ (newline)
+ (let ((passed
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if passed
+ (display "Passed!")
+ (display "Failed!"))))))
+
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+
+;; Exercise 4.56. Formulate compound queries that retrieve the following information:
+
+;; a. the names of all people who are supervised by Ben Bitdiddle, together with their addresses;
+
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+
+;; b. all people whose salary is less than Ben Bitdiddle's, together with their salary and Ben Bitdiddle's salary;
+
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+
+;; c. all people who are supervised by someone who is not in the computer division, together with the supervisor's name and job.
+
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
blob - /dev/null
blob + 24c5b5a2e99a12b4e91373ccd1777892e6cd1a47 (mode 644)
--- /dev/null
+++ ex4-56.scm~
+(assert! (job (Bitdiddle Ben) (computer wizard)))
+(assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+(assert! (salary (Bitdiddle Ben) 60000))
+(supervisor (Bitdiddle Ben) (Warbucks Oliver))
+(job (Reasoner Louis) (computer programmer trainee))
+(job ?x (computer programmer))
+(address ?x ?y)
+(supervisor ?x ?x)
+(job ?x (computer . ?type))
+(and (job ?person (computer programmer))
+ (address ?person ?where))
+(or (supervisor ?x (Bitdiddle Ben))
+ (supervisor ?x (Hacker Alyssa P)))
+(not <query>)
+(lisp-value <pred> <arg> <arg>)
+(and (supervisor ?x (Bitdiddle Ben))
+ (not (job ?x (computer programmer))))
+(and (salary ?person ?amount)
+ (lisp-value > ?amount 30000))
+
+(rule (same ?x ?x))
+(rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))))
+(rule (wheel ?person)
+ (and (supervisor ?middle-manager ?person)
+ (supervisor ?x ?middle-manager)))
+(lives-near ?x (Bitdiddle Ben))
blob - /dev/null
blob + 01816fbc3baa9a699dc6d3b29d08dcdd429f052d (mode 644)
--- /dev/null
+++ ex4-57.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+;; Exercise 4.57. Define a rule that says that person 1 can replace person 2 if either person 1 does the same job as person 2 or someone who does person 1's job can also do person 2's job, and if person 1 and person 2 are not the same person. Using your rule, give queries that find the following:
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+
+;; a. all people who can replace Cy D. Fect;
+
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+
+;; b. all people who can replace someone who is being paid more than they are, together with the two salaries.
+
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
blob - /dev/null
blob + fc71c76064a7c0d39bdcff1ac61ee4b5f53df302 (mode 644)
--- /dev/null
+++ ex4-57.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (display-stream (eval-query query))
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+ (let ((list (car expected)))
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+ (newline)
+ (display query)
+ (newline)
+ (let ((passed
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if passed
+ (display "Passed!")
+ (display "Failed!"))))))
+
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+
+;; Exercise 4.57. Define a rule that says that person 1 can replace person 2 if either person 1 does the same job as person 2 or someone who does person 1's job can also do person 2's job, and if person 1 and person 2 are not the same person. Using your rule, give queries that find the following:
+
+(test-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+
+;; a. all people who can replace Cy D. Fect;
+
+(test-query
+ '(can-replace? ?x (Fect Cy D)))
+
+;; b. all people who can replace someone who is being paid more than they are, together with the two salaries.
+
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary)))
blob - /dev/null
blob + 59c9100968594d14f0f597ff4a057a80a7391fc2 (mode 644)
--- /dev/null
+++ ex4-58.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+
+;; Exercise 4.58. Define a rule that says that a person is a ``big shot'' in a division if the person works in the division but does not have a supervisor who works in the division.
+
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
blob - /dev/null
blob + 01816fbc3baa9a699dc6d3b29d08dcdd429f052d (mode 644)
--- /dev/null
+++ ex4-58.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+;; Exercise 4.57. Define a rule that says that person 1 can replace person 2 if either person 1 does the same job as person 2 or someone who does person 1's job can also do person 2's job, and if person 1 and person 2 are not the same person. Using your rule, give queries that find the following:
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+
+;; a. all people who can replace Cy D. Fect;
+
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+
+;; b. all people who can replace someone who is being paid more than they are, together with the two salaries.
+
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
blob - /dev/null
blob + 3f4b4a818eb5bdd707e7093e187d0cebe2b3c270 (mode 644)
--- /dev/null
+++ ex4-59.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+
+;; Exercise 4.59. Ben Bitdiddle has missed one meeting too many. Fearing that his habit of forgetting meetings could cost him his job, Ben decides to do something about it. He adds all the weekly meetings of the firm to the Microshaft data base by asserting the following:
+
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+
+;; Each of the above assertions is for a meeting of an entire division. Ben also adds an entry for the company-wide meeting that spans all the divisions. All of the company's employees attend this meeting.
+
+;; a. On Friday morning, Ben wants to query the data base for all the meetings that occur that day. What query should he use?
+
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+
+;; b. Alyssa P. Hacker is unimpressed. She thinks it would be much more useful to be able to ask for her meetings by specifying her name. So she designs a rule that says that a person's meetings include all whole-company meetings plus all meetings of that person's division. Fill in the body of Alyssa's rule.
+
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+;; c. Alyssa arrives at work on Wednesday morning and wonders what meetings she has to attend that day. Having defined the above rule, what query should she make to find this out?
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+
blob - /dev/null
blob + 59c9100968594d14f0f597ff4a057a80a7391fc2 (mode 644)
--- /dev/null
+++ ex4-59.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+
+;; Exercise 4.58. Define a rule that says that a person is a ``big shot'' in a division if the person works in the division but does not have a supervisor who works in the division.
+
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
blob - /dev/null
blob + 30144651cb49f73da1a49e9774d9274bbaa8ae56 (mode 644)
--- /dev/null
+++ ex4-6.scm
+(define apply-in-underlying-scheme apply)
+(define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; Exercise 4.1. Notice that we cannot tell whether the metacircular evaluator evaluates operands from left to right or from right to left. Its evaluation order is inherited from the underlying Lisp: If the arguments to cons in list-of-values are evaluated from left to right, then list-of-values will evaluate operands from left to right; and if the arguments to cons are evaluated from right to left, then list-of-values will evaluate operands from right to left.
+
+;; Write a version of list-of-values that evaluates operands from left to right regardless of the order of evaluation in the underlying Lisp. Also write a version of list-of-values that evaluates operands from right to left.
+
+;; Exercise 4.6. Let expressions are derived expressions, because
+
+;; (let ((<var1> <exp1>) ... (<varn> <expn>))
+;; <body>)
+
+;; is equivalent to
+
+;; ((lambda (<var1> ... <varn>)
+;; <body>)
+;; <exp1>
+
+;; <expn>)
+
+;; Implement a syntactic transformation let->combination that reduces evaluating let expressions to evaluating combinations of the type shown above, and add the appropriate clause to eval to handle let expressions.
+
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (cons (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(test-case (eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ the-global-environment)
+ (+ 4 7 (* 4 7)))
+;; (eval
+;; '(define old-value
+;; (let ((x 0))
+;; (lambda (y)
+;; (let ((z x))
+;; (set! x y)
+;; z))))
+;; the-global-environment)
+;; (eval '
+;; (define (print
+
+;; (eval-test-case '((old-value 5) (old-value 3)
blob - /dev/null
blob + d8da0a4c788407fe1fa285ea485d2f022cfc464b (mode 644)
--- /dev/null
+++ ex4-6.scm~
+(define apply-in-underlying-scheme apply)
+(define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ <more primitives>
+ ))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; Exercise 4.1. Notice that we cannot tell whether the metacircular evaluator evaluates operands from left to right or from right to left. Its evaluation order is inherited from the underlying Lisp: If the arguments to cons in list-of-values are evaluated from left to right, then list-of-values will evaluate operands from left to right; and if the arguments to cons are evaluated from right to left, then list-of-values will evaluate operands from right to left.
+
+;; Write a version of list-of-values that evaluates operands from left to right regardless of the order of evaluation in the underlying Lisp. Also write a version of list-of-values that evaluates operands from right to left.
+
+;; Exercise 4.6. Let expressions are derived expressions, because
+
+(let ((<var1> <exp1>) ... (<varn> <expn>))
+ <body>)
+
+;; is equivalent to
+
+((lambda (<var1> ... <varn>)
+ <body>)
+ <exp1>
+
+ <expn>)
+
+;; Implement a syntactic transformation let->combination that reduces evaluating let expressions to evaluating combinations of the type shown above, and add the appropriate clause to eval to handle let expressions.
+
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (cons (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(eval '(define old-value
+ (let ((x 0))
+ (lambda (y)
+ (let ((z x))
+ (set! x y)
+ z))))
+ the-global-environment)
+(eval '
+(define (print
+
+(eval-test-case '((old-value 5) (old-value 3)
blob - /dev/null
blob + 1885821c59ad01acd1b87ce504b13f5b08449b1a (mode 644)
--- /dev/null
+++ ex4-60.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+;; Exercise 4.60. By giving the query
+
+;; (rule (lives-near ?person (Hacker Alyssa P)))))
+
+;; Alyssa P. Hacker is able to find people who live near her, with whom she can ride to work. On the other hand, when she tries to find all pairs of people who live near each other by querying
+
+;; (lives-near ?person-1 ?person-2)
+
+;; she notices that each pair of people who live near each other is listed twice; for example,
+
+;; (lives-near (Hacker Alyssa P) (Fect Cy D))
+;; (lives-near (Fect Cy D) (Hacker Alyssa P))
+
+;; Why does this happen? Is there a way to find a list of people who live near each other, in which each pair appears only once? Explain.
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
blob - /dev/null
blob + 3f4b4a818eb5bdd707e7093e187d0cebe2b3c270 (mode 644)
--- /dev/null
+++ ex4-60.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+
+;; Exercise 4.59. Ben Bitdiddle has missed one meeting too many. Fearing that his habit of forgetting meetings could cost him his job, Ben decides to do something about it. He adds all the weekly meetings of the firm to the Microshaft data base by asserting the following:
+
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+
+;; Each of the above assertions is for a meeting of an entire division. Ben also adds an entry for the company-wide meeting that spans all the divisions. All of the company's employees attend this meeting.
+
+;; a. On Friday morning, Ben wants to query the data base for all the meetings that occur that day. What query should he use?
+
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+
+;; b. Alyssa P. Hacker is unimpressed. She thinks it would be much more useful to be able to ask for her meetings by specifying her name. So she designs a rule that says that a person's meetings include all whole-company meetings plus all meetings of that person's division. Fill in the body of Alyssa's rule.
+
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+;; c. Alyssa arrives at work on Wednesday morning and wonders what meetings she has to attend that day. Having defined the above rule, what query should she make to find this out?
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+
blob - /dev/null
blob + faf6d651200453320b2c24a200a897bcf0221684 (mode 644)
--- /dev/null
+++ ex4-61.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+
+;; Exercise 4.61. The following rules implement a next-to relation that finds adjacent elements of a list:
+
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+
+;; (?x next-to ?y in (?v . ?z))
+;; (?x next-to ?y in (1 (2 3) 4))
+;; ?v -> 1
+;; ?z -> ((2 3) 4)
+;; (?x next-to ?y in ?z)
+;; (?x next-to ?y in ((2 3) 4))
+;; (?x next-to ?y in (?x ?y . ?u))
+
+;; ?x -> (2 3)
+;; ?y -> 4
+;; ((2 3) next-to 4 in (1 (2 3) 4))
+
+;; (?x next-to ?y in ((2 3) 4))
+;; (?x next-to ?y in (?v . ?z))
+;; ?v -> (2 3)
+;; ?z -> (4)
+
+;; (?x next-to ?y in ?z)
+;; (?x next-to ?y in (4))
+
+;; What will the response be to the following queries?
+
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+
+;; (?x next-to 1 in (2 1 3 1))
+;; (?x next-to ?y in (?x ?y . ?u))
+;; ?y -> 1
+;; ?x -> 2
+;; ?u -> (3 1)
+;; (2 next-to 1 in (2 1 3 1))
+
+;; (?x next-to 1 in (2 1 3 1))
+;; (?x next-to ?y in (?v . ?z))
+;; ?y -> 1
+;; ?v -> 2
+;; ?z -> (1 3 1)
+
+;; (?x next-to 1 in (1 3 1))
+;; (?x next-to ?y in (?x ?y . ?u))
+;; ?y -> 1
+;; ?x -> 1
+;; ?y -> 3 ;; failed
+
+;; (?x next-to 1 in (1 3 1))
+;; (?x next-to ?y in (?v . ?z))
+;; ?y -> 1
+;; ?v -> 1
+;; ?z -> (3 1)
+
+;; (?x next-to 1 in (3 1))
+;; (?x next-to ?y in (?x ?y . ?u))
+;; ?y -> 1
+;; ?x -> 3
+;; ?y -> 1
+;; ?u -> ()
+;; (3 next-to 1 in (2 1 3 1))
+
+;; (?x next-to 1 in (3 1))
+;; (?x next-to ?y in (?v . ?z))
+
+;; ?y -> 1
+;; ?v -> 3
+;; ?z -> (1)
+;; (?x next-to ?y in ?z)
+;; (?x next-to 1 in (1))
+;; (?x next-to ?y in (?x ?y . ?u))
+;; ?y -> 1
+;; ?x -> 1
+;; ;; fail because () is not a pair
+
+;; (?x next-to 1 in (1))
+;; (?x next-to ?y in (?v . ?z))
+;; ?y -> 1
+;; ?v -> 1
+;; ?z -> ()
+
+;; (?x next-to ?y in ?z)
+;; (?x next-to 1 in ())
+;; ... this will also fail...
+
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+
blob - /dev/null
blob + 1885821c59ad01acd1b87ce504b13f5b08449b1a (mode 644)
--- /dev/null
+++ ex4-61.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+;; Exercise 4.60. By giving the query
+
+;; (rule (lives-near ?person (Hacker Alyssa P)))))
+
+;; Alyssa P. Hacker is able to find people who live near her, with whom she can ride to work. On the other hand, when she tries to find all pairs of people who live near each other by querying
+
+;; (lives-near ?person-1 ?person-2)
+
+;; she notices that each pair of people who live near each other is listed twice; for example,
+
+;; (lives-near (Hacker Alyssa P) (Fect Cy D))
+;; (lives-near (Fect Cy D) (Hacker Alyssa P))
+
+;; Why does this happen? Is there a way to find a list of people who live near each other, in which each pair appears only once? Explain.
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
blob - /dev/null
blob + e6ad59fc108f91f8673a70f3f828ddcc1dd09a38 (mode 644)
--- /dev/null
+++ ex4-62.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+
+;; Exercise 4.62. Define rules to implement the last-pair operation of exercise 2.17, which returns a list containing the last element of a nonempty list. Check your rules on queries such as (last-pair (3) ?x), (last-pair (1 2 3) ?x), and (last-pair (2 ?x) (3)). Do your rules work correctly on queries such as (last-pair ?x (3)) ?
+
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+;; (test-query '(last-pair ?x (3)))
+;; infinite loop
+
+;; (last-pair ?x (3))
+;; (rule (last-pair (?x . ?y) (?z))
+;; (last-pair ?y (?z)))
+
+;; (last-pair ?x (3))
+;; (last-pair (?x1 . ?y1) (?z1))
+;; ?x -> (?x1 . ?y1)
+;; ?z1 -> 3
+
+;; (last-pair ?y1 (?z1))
+;; (last-pair ?y1 (?3))
+
+;; ;; this goes on forever
+
+;; (last-pair ?y2 (?z))
+;; (last-pair ?y3 (?z))
blob - /dev/null
blob + faf6d651200453320b2c24a200a897bcf0221684 (mode 644)
--- /dev/null
+++ ex4-62.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+
+;; Exercise 4.61. The following rules implement a next-to relation that finds adjacent elements of a list:
+
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+
+;; (?x next-to ?y in (?v . ?z))
+;; (?x next-to ?y in (1 (2 3) 4))
+;; ?v -> 1
+;; ?z -> ((2 3) 4)
+;; (?x next-to ?y in ?z)
+;; (?x next-to ?y in ((2 3) 4))
+;; (?x next-to ?y in (?x ?y . ?u))
+
+;; ?x -> (2 3)
+;; ?y -> 4
+;; ((2 3) next-to 4 in (1 (2 3) 4))
+
+;; (?x next-to ?y in ((2 3) 4))
+;; (?x next-to ?y in (?v . ?z))
+;; ?v -> (2 3)
+;; ?z -> (4)
+
+;; (?x next-to ?y in ?z)
+;; (?x next-to ?y in (4))
+
+;; What will the response be to the following queries?
+
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+
+;; (?x next-to 1 in (2 1 3 1))
+;; (?x next-to ?y in (?x ?y . ?u))
+;; ?y -> 1
+;; ?x -> 2
+;; ?u -> (3 1)
+;; (2 next-to 1 in (2 1 3 1))
+
+;; (?x next-to 1 in (2 1 3 1))
+;; (?x next-to ?y in (?v . ?z))
+;; ?y -> 1
+;; ?v -> 2
+;; ?z -> (1 3 1)
+
+;; (?x next-to 1 in (1 3 1))
+;; (?x next-to ?y in (?x ?y . ?u))
+;; ?y -> 1
+;; ?x -> 1
+;; ?y -> 3 ;; failed
+
+;; (?x next-to 1 in (1 3 1))
+;; (?x next-to ?y in (?v . ?z))
+;; ?y -> 1
+;; ?v -> 1
+;; ?z -> (3 1)
+
+;; (?x next-to 1 in (3 1))
+;; (?x next-to ?y in (?x ?y . ?u))
+;; ?y -> 1
+;; ?x -> 3
+;; ?y -> 1
+;; ?u -> ()
+;; (3 next-to 1 in (2 1 3 1))
+
+;; (?x next-to 1 in (3 1))
+;; (?x next-to ?y in (?v . ?z))
+
+;; ?y -> 1
+;; ?v -> 3
+;; ?z -> (1)
+;; (?x next-to ?y in ?z)
+;; (?x next-to 1 in (1))
+;; (?x next-to ?y in (?x ?y . ?u))
+;; ?y -> 1
+;; ?x -> 1
+;; ;; fail because () is not a pair
+
+;; (?x next-to 1 in (1))
+;; (?x next-to ?y in (?v . ?z))
+;; ?y -> 1
+;; ?v -> 1
+;; ?z -> ()
+
+;; (?x next-to ?y in ?z)
+;; (?x next-to 1 in ())
+;; ... this will also fail...
+
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+
blob - /dev/null
blob + 7fe3aeb75bacc4ffc5ad56aadb6ab36fd692af5c (mode 644)
--- /dev/null
+++ ex4-63.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+
+
+;; Exercise 4.63. The following data base (see Genesis 4) traces the genealogy of the descendants of Ada back to Adam, by way of Cain:
+
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+
+;; Formulate rules such as ``If S is the son of F, and F is the son of G, then S is the grandson of G'' and ``If W is the wife of M, and S is the son of W, then S is the son of M'' (which was supposedly more true in biblical times than today) that will enable the query system to find the grandson of Cain; the sons of Lamech; the grandsons of Methushael. (See exercise 4.69 for some rules to deduce more complicated relationships.)
+
+
+
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
blob - /dev/null
blob + e6ad59fc108f91f8673a70f3f828ddcc1dd09a38 (mode 644)
--- /dev/null
+++ ex4-63.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+
+;; Exercise 4.62. Define rules to implement the last-pair operation of exercise 2.17, which returns a list containing the last element of a nonempty list. Check your rules on queries such as (last-pair (3) ?x), (last-pair (1 2 3) ?x), and (last-pair (2 ?x) (3)). Do your rules work correctly on queries such as (last-pair ?x (3)) ?
+
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+;; (test-query '(last-pair ?x (3)))
+;; infinite loop
+
+;; (last-pair ?x (3))
+;; (rule (last-pair (?x . ?y) (?z))
+;; (last-pair ?y (?z)))
+
+;; (last-pair ?x (3))
+;; (last-pair (?x1 . ?y1) (?z1))
+;; ?x -> (?x1 . ?y1)
+;; ?z1 -> 3
+
+;; (last-pair ?y1 (?z1))
+;; (last-pair ?y1 (?3))
+
+;; ;; this goes on forever
+
+;; (last-pair ?y2 (?z))
+;; (last-pair ?y3 (?z))
blob - /dev/null
blob + 0c9df8be53b3449bfcd4af6f53d3c9e2839d3657 (mode 644)
--- /dev/null
+++ ex4-64.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+;; Exercise 4.64. Louis Reasoner mistakenly deletes the outranked-by rule (section 4.4.1) from the data base. When he realizes this, he quickly reinstalls it. Unfortunately, he makes a slight change in the rule, and types it in as
+
+(rule (outranked-by ?staff-person ?boss)
+ (or (supervisor ?staff-person ?boss)
+ (and (outranked-by ?middle-manager ?boss)
+ (supervisor ?staff-person ?middle-manager))))
+
+;; Just after Louis types this information into the system, DeWitt Aull comes by to find out who outranks Ben Bitdiddle. He issues the query
+
+(outranked-by (Bitdiddle Ben) ?who)
+
+;; After answering, the system goes into an infinite loop. Explain why.
+
+;; originally, (supervisor ?staff-person ?middle-manager) created bindings for ?middle-manager so that (outranked-by ?middle-manager ?boss) had bindings for both pattern variables, but with the new rule, ?middle-manager will not have any bindings when (outranked-by ?middle-manager ?boss) is evaluated and so the rule body never gets any more specific
blob - /dev/null
blob + 7fe3aeb75bacc4ffc5ad56aadb6ab36fd692af5c (mode 644)
--- /dev/null
+++ ex4-64.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+
+
+;; Exercise 4.63. The following data base (see Genesis 4) traces the genealogy of the descendants of Ada back to Adam, by way of Cain:
+
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+
+;; Formulate rules such as ``If S is the son of F, and F is the son of G, then S is the grandson of G'' and ``If W is the wife of M, and S is the son of W, then S is the son of M'' (which was supposedly more true in biblical times than today) that will enable the query system to find the grandson of Cain; the sons of Lamech; the grandsons of Methushael. (See exercise 4.69 for some rules to deduce more complicated relationships.)
+
+
+
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
blob - /dev/null
blob + cb1545b85b91bbbab542d5a83590e096ccadefb4 (mode 644)
--- /dev/null
+++ ex4-65.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+
+ Exercise 4.65. Cy D. Fect, looking forward to the day when he will rise in the organization, gives a query to find all the wheels (using the wheel rule of section 4.4.1):
+
+(wheel ?who)
+
+To his surprise, the system responds
+
+;;; Query results:
+(wheel (Warbucks Oliver))
+(wheel (Bitdiddle Ben))
+(wheel (Warbucks Oliver))
+(wheel (Warbucks Oliver))
+(wheel (Warbucks Oliver))
+
+Why is Oliver Warbucks listed four times?
blob - /dev/null
blob + 0c9df8be53b3449bfcd4af6f53d3c9e2839d3657 (mode 644)
--- /dev/null
+++ ex4-65.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+;; Exercise 4.64. Louis Reasoner mistakenly deletes the outranked-by rule (section 4.4.1) from the data base. When he realizes this, he quickly reinstalls it. Unfortunately, he makes a slight change in the rule, and types it in as
+
+(rule (outranked-by ?staff-person ?boss)
+ (or (supervisor ?staff-person ?boss)
+ (and (outranked-by ?middle-manager ?boss)
+ (supervisor ?staff-person ?middle-manager))))
+
+;; Just after Louis types this information into the system, DeWitt Aull comes by to find out who outranks Ben Bitdiddle. He issues the query
+
+(outranked-by (Bitdiddle Ben) ?who)
+
+;; After answering, the system goes into an infinite loop. Explain why.
+
+;; originally, (supervisor ?staff-person ?middle-manager) created bindings for ?middle-manager so that (outranked-by ?middle-manager ?boss) had bindings for both pattern variables, but with the new rule, ?middle-manager will not have any bindings when (outranked-by ?middle-manager ?boss) is evaluated and so the rule body never gets any more specific
blob - /dev/null
blob + 438141b8c69682c01fe6777e28a231157dff647b (mode 644)
--- /dev/null
+++ ex4-68.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+;; Exercise 4.68. Define rules to implement the reverse operation of exercise 2.18, which returns a list containing the same elements as a given list in reverse order. (Hint: Use append-to-form.) Can your rules answer both (reverse (1 2 3) ?x) and (reverse ?x (1 2 3)) ?
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+;; (test-query '(reverse ?x (1 2 3)))
+;; this goes into an infinite loop
+
+;; (reverse ?x (1 2 3))
+;; (reverse (?x1 . ?y1) ?rev1)
+;; ?x -> (?x1 . ?y1)
+;; ?rev1 -> (1 2 3)
+
+;; (and (reverse ?y1 ?rev-y1)
+;; (append-to-form ?rev-y1 (?x1) ?rev1))
+;; (and (reverse ?y1 (1 2 3))
+;; (append-to-form (1 2 3) (?x1) (1 2 3)))
+
+;; notice how (reverse ?x (1 2 3)) leads to (reverse ?y1 (1 2 3)) ... it keeps calling itself and therefore goes into an infinte loop
blob - /dev/null
blob + cb1545b85b91bbbab542d5a83590e096ccadefb4 (mode 644)
--- /dev/null
+++ ex4-68.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+
+ Exercise 4.65. Cy D. Fect, looking forward to the day when he will rise in the organization, gives a query to find all the wheels (using the wheel rule of section 4.4.1):
+
+(wheel ?who)
+
+To his surprise, the system responds
+
+;;; Query results:
+(wheel (Warbucks Oliver))
+(wheel (Bitdiddle Ben))
+(wheel (Warbucks Oliver))
+(wheel (Warbucks Oliver))
+(wheel (Warbucks Oliver))
+
+Why is Oliver Warbucks listed four times?
blob - /dev/null
blob + 904029d4ed7dcf667b7089319040712eb2074799 (mode 644)
--- /dev/null
+++ ex4-69.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+
+ ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
+
+(eval-queries
+ '((assert! (rule (ends-in-grandson? (grandson))))
+ (assert! (rule (ends-in-grandson? (?x . ?y))
+ (ends-in-grandson? ?y)))))
+;; (test-query '(ends-in-grandson? (father)))
+;; (test-query '(ends-in-grandson? (son mother father)))
+;; (test-query '(ends-in-grandson? (grandson)))
+;; (test-query '(ends-in-grandson? (father son grandson mother)))
+;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
+
+(eval-queries
+ '((assert! (rule ((great . ?rel) ?x ?y)
+ (and (ends-in-grandson? ?rel)
+ (son ?x ?z)
+ (?rel ?z ?y))))
+ (assert! (rule ((grandson) ?x ?y)
+ (grandson ?x ?y)))))
+
+;; ((great great great grandson) Adam ?somebody)
+;; ((great . ?rel) ?x ?y)
+
+;; ?rel -> (great great grandson)
+;; ?x -> Adam
+;; ?somebody -> ?y
+
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y))
+;; (and (son Adam ?z)
+;; ((great great grandson) ?z ?y))
+
+;; (son Adam ?z)
+;; (son Adam Cain)
+;; ?z -> Cain
+
+;; ((great great grandson) Cain ?y)
+;; ((great . ?rel1) ?x1 ?y1)
+;; ?rel1 -> (great grandson)
+;; ?x1 -> Cain
+;; ?y -> ?y1
+;; (and (son Cain ?z1)
+;; ((great grandson) ?z1 ?y1))
+;; ?z1 -> Enoch
+;; ((great grandson) Enoch ?y1)
+;; ((great . ?rel2) ?x2 ?y2)
+;; ?rel2 -> (grandson)
+;; ?x2 -> Enoch
+;; ?y1 -> ?y2
+;; (and (son Enoch ?z2)
+;; ((grandson) ?z2 ?y2))
+;; ?z2 -> Irad
+;; ((grandson) Irad ?y2)
+
+;; (assert! (son Adam Cain))
+;; (assert! (son Cain Enoch))
+;; (assert! (son Enoch Irad))
+;; (assert! (son Irad Mehujael))
+;; (assert! (son Mehujael Methushael))
+;; (assert! (son Methushael Lamech))
+;; (assert! (wife Lamech Ada))
+;; (assert! (son Ada Jabal))
+;; (assert! (son Ada Jubal))
+
+(test-query '((great grandson) ?great-grandfather Irad)
+ '(((great grandson) Adam Irad)))
+(test-query '((great great great great great grandson) Adam ?x)
+ '(((great great great great great grandson) Adam Jubal)
+ ((great great great great great grandson) Adam Jabal)))
+
+(test-query '((great grandson) ?g ?ggs)
+ '(((great grandson) mehujael jubal)
+ ((great grandson) irad lamech)
+ ((great grandson) mehujael jabal)
+ ((great grandson) enoch methushael)
+ ((great grandson) cain mehujael)
+ ((great grandson) adam irad)))
+
+;; (test-query '(?relationship Adam Irad))
+;; this goes into an infinite loop
+
+;; (?relationship Adam Irad)
+
+;; (rule (ends-in-grandson? (grandson)))
+;; (rule (ends-in-grandson? (?x . ?y))
+;; (ends-in-grandson? ?y))
+;; (rule ((great . ?rel) ?x ?y)
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y)))
+;; (rule ((grandson) ?x ?y)
+;; (grandson ?x ?y))
+
+;; (?relationship Adam Irad)
+;; ((grandson) ?x ?y)
+;; ?relationship -> (grandson)
+;; ?x -> Adam
+;; ?y -> Irad
+
+;; (grandson Adam Irad) -- fails
+
+;; (?relationship Adam Irad)
+;; ((great . ?rel) ?x ?y)
+;; ?relationship -> (great . ?rel)
+;; ?x -> Adam
+;; ?y -> Irad
+
+;; (and (ends-in-grandson? (great . ?rel))
+;; (son Adam ?z)
+;; (?rel ?z Irad))
+
+;; (ends-in-grandson? (great . ?rel))
+;; (ends-in-grandson? (?x1 . ?y1))
+
+;; ?x1 -> great
+;; ?rel -> ?y1
+
+;; (ends-in-grandson? ?rel)
blob - /dev/null
blob + a978aba59f445729edd52298f1bfe4a8787db2b2 (mode 644)
--- /dev/null
+++ ex4-69.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+
+ ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
+
+(eval-queries
+ '((assert! (rule (ends-in-grandson? (grandson))))
+ (assert! (rule (ends-in-grandson? (?x . ?y))
+ (ends-in-grandson? ?y)))))
+;; (test-query '(ends-in-grandson? (father)))
+;; (test-query '(ends-in-grandson? (son mother father)))
+;; (test-query '(ends-in-grandson? (grandson)))
+;; (test-query '(ends-in-grandson? (father son grandson mother)))
+;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
+
+(eval-query
+ '(assert! (rule ((great . ?rel) ?x ?y)
+ (and (ends-in-grandson? ?rel)
+ (son ?x ?z)
+ (?rel ?z ?y)))))
+
+;; ((great great great grandson) Adam ?somebody)
+;; ((great . ?rel) ?x ?y)
+
+;; ?rel -> (great great grandson)
+;; ?x -> Adam
+;; ?somebody -> ?y
+
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y))
+;; (and (son Adam ?z)
+;; ((great great grandson) ?z ?y))
+
+;; (son Adam ?z)
+;; (son Adam Cain)
+;; ?z -> Cain
+
+;; ((great great grandson) Cain ?y)
+;; ((great . ?rel1) ?x1 ?y1)
+;; ?rel1 -> (great grandson)
+;; ?x1 -> Cain
+;; ?y -> ?y1
+;; (and (son Cain ?z1)
+;; ((great grandson) ?z1 ?y1))
+;; ?z1 -> Enoch
+;; ((great grandson) Enoch ?y1)
+;; ((great . ?rel2) ?x2 ?y2)
+;; ?rel2 -> (grandson)
+;; ?x2 -> Enoch
+;; ?y1 -> ?y2
+;; (and (son Enoch ?z2)
+;; ((grandson) ?z2 ?y2))
+;; ?z2 -> Irad
+;; ((grandson) Irad ?y2)
+
+;; (assert! (son Adam Cain))
+;; (assert! (son Cain Enoch))
+;; (assert! (son Enoch Irad))
+;; (assert! (son Irad Mehujael))
+;; (assert! (son Mehujael Methushael))
+;; (assert! (son Methushael Lamech))
+;; (assert! (wife Lamech Ada))
+;; (assert! (son Ada Jabal))
+;; (assert! (son Ada Jubal))
+
+(test-query '((great grandson) ?great-grandfather Irad)
+ '(((great grandson) Adam Irad)))
+(test-query '((great great great great great grandson) Adam ?x)
+ '(((great great great great great grandson) Adam Jabal)
+ ((great great great great great grandson) Adam Jubal)))
+;; ((great great grandson
+(test-query '((great grandson) ?g ?ggs))
+(test-query '(?relationship Adam Irad))
+;; (test-query '((great grandson))
blob - /dev/null
blob + 8aa6e516a1b9e7e68d1395885688b453ab19003f (mode 644)
--- /dev/null
+++ ex4-7.lisp
+(defun let*->nested-lets (exp)
+ (labels (
+ (make-rec-let (initforms body)
+ (if (null initforms)
+ body
+ (make-let
+ (list (car initforms))
+ (make-rec-let (cdr initforms) body)))))
+ (make-rec-let (cadr exp) (caddr exp))))
blob - /dev/null
blob + a905d2c136f4a86651155b5661ad9ebed7cdf15a (mode 644)
--- /dev/null
+++ ex4-7.scm
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+ ;; Exercise 4.7. Let* is similar to let, except that the bindings of the let variables are performed sequentially from left to right, and each binding is made in an environment in which all of the preceding bindings are visible. For example
+
+(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+
+;; returns 39. Explain how a let* expression can be rewritten as a set of nested let expressions, and write a procedure let*->nested-lets that performs this transformation. If we have already implemented let (exercise 4.6) and we want to extend the evaluator to handle let*, is it sufficient to add a clause to eval whose action is
+
+;; (eval (let*->nested-lets exp) env)
+
+;; or must we explicitly expand let* in terms of non-derived expressions?
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; x = 6
+;; a = 8
+;; y = 10
+;; z = 16
+;; 32
blob - /dev/null
blob + d6b6ae763ac7a97a52728d1a95ad9a9000976fc2 (mode 644)
--- /dev/null
+++ ex4-7.scm~
+;; (define apply-in-underlying-scheme apply)
+;; (define eval-in-underlying-scheme eval)
+
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+(define (text-of-quotation exp) (cadr exp))
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+;; Exercise 4.4. Recall the definitions of the special forms and and or from chapter 1:
+
+;; and: The expressions are evaluated from left to right. If any expression evaluates to false, false is returned; any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then true is returned.
+
+;; or: The expressions are evaluated from left to right. If any expression evaluates to a true value, that value is returned; any remaining expressions are not evaluated. If all expressions evaluate to false, or if there are no expressions, then false is returned.
+
+;; Install and and or as new special forms for the evaluator by defining appropriate syntax procedures and evaluation procedures eval-and and eval-or. Alternatively, show how to implement and and or as derived expressions.
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+;; (define (and->if exp)
+;; (define (expand-clauses clauses)
+;; (cond ((null? clauses) 'true)
+;; ((null? (cdr clauses)) (car clauses))
+;; (else (make-if (car clauses)
+;; (expand-clauses (cdr clauses))
+;; 'false))))
+;; (expand-clauses (and-clauses exp)))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+;; the problem with this definition is that each clause will be evaluated twice; this is unacceptable if there are side effects
+;; (define (or->if exp)
+;; (define (expand-clauses clauses)
+;; (if (null? clauses)
+;; 'false
+;; (make-if (car clauses)
+;; (car clauses)
+;; (expand-clauses (cdr clauses)))))
+;; (expand-clauses (or-clauses exp)))
+
+
+;; we can also install and/or as special forms
+
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; Exercise 4.5. Scheme allows an additional syntax for cond clauses, (<test> => <recipient>). If <test> evaluates to a true value, then <recipient> is evaluated. Its value must be a procedure of one argument; this procedure is then invoked on the value of the <test>, and the result is returned as the value of the cond expression. For example
+
+;; (cond ((assoc 'b '((a 1) (b 2))) => cadr)
+;; (else false))
+
+;; returns 2. Modify the handling of cond so that it supports this extended syntax.
+
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; cond
+
+(test-case
+ (geval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false)))
+ 2)
+
+(test-case
+ (geval '((lambda (x)
+ (accumulate + 0 x))
+ (map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))))
+ 118)
+
+(test-case
+ (geval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach)))
+ 118)
+;; '(6 20 2 90)
+
+
+;; test-suite
+
+;; make-let
+(test-case (geval (make-let '(x y) '(3 5) '((+ x y))))
+ 8)
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-case (geval '(and 0 true x)) 11)
+(test-case (geval '(and 0 true x false)) false)
+(test-case (geval '(and 0 true x (set! x -2) false)) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(and 0 true x false (set! x -5))) false)
+(test-case (geval 'x) -2)
+(test-case (geval '(or false (set! x 25))) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or (set! x 2) (set! x 4))) 'ok)
+(test-case (geval 'x) 2)
+(test-case (geval '(or false (set! x 25) true false)) 'ok)
+(test-case (geval 'x) 25)
+(test-case (geval '(or ((lambda (x) x) 5))) 5)
+(test-case (geval '(or (begin (set! x (+ x 1)) x))) 26)
+
+
+;; all special forms
+(test-case (geval '(begin 5 6)) 6)
+(test-case (geval '10) 10)
+(geval '(define x 3))
+(test-case (geval 'x) 3)
+(test-case (geval '(set! x -25)) 'ok)
+(test-case (geval 'x) -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-case (geval '(z 3 4)) 15)
+(test-case (geval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-case (geval '(if true false true)) false)
+(test-case (geval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-case (geval '(factorial 5)) 120)
+
+;; map
+
+(test-case
+ (geval '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3)))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-case
+ (geval
+ '(accumulate + 0 '(1 2 3 4 5)))
+ 15)
blob - /dev/null
blob + cf07f4fc5b31363c5271f3313ae25a577b31e72c (mode 644)
--- /dev/null
+++ ex4-70.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+
+ ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
+
+(eval-queries
+ '((assert! (rule (ends-in-grandson? (grandson))))
+ (assert! (rule (ends-in-grandson? (?x . ?y))
+ (ends-in-grandson? ?y)))))
+;; (test-query '(ends-in-grandson? (father)))
+;; (test-query '(ends-in-grandson? (son mother father)))
+;; (test-query '(ends-in-grandson? (grandson)))
+;; (test-query '(ends-in-grandson? (father son grandson mother)))
+;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
+
+(eval-queries
+ '((assert! (rule ((great . ?rel) ?x ?y)
+ (and (ends-in-grandson? ?rel)
+ (son ?x ?z)
+ (?rel ?z ?y))))
+ (assert! (rule ((grandson) ?x ?y)
+ (grandson ?x ?y)))))
+
+;; ((great great great grandson) Adam ?somebody)
+;; ((great . ?rel) ?x ?y)
+
+;; ?rel -> (great great grandson)
+;; ?x -> Adam
+;; ?somebody -> ?y
+
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y))
+;; (and (son Adam ?z)
+;; ((great great grandson) ?z ?y))
+
+;; (son Adam ?z)
+;; (son Adam Cain)
+;; ?z -> Cain
+
+;; ((great great grandson) Cain ?y)
+;; ((great . ?rel1) ?x1 ?y1)
+;; ?rel1 -> (great grandson)
+;; ?x1 -> Cain
+;; ?y -> ?y1
+;; (and (son Cain ?z1)
+;; ((great grandson) ?z1 ?y1))
+;; ?z1 -> Enoch
+;; ((great grandson) Enoch ?y1)
+;; ((great . ?rel2) ?x2 ?y2)
+;; ?rel2 -> (grandson)
+;; ?x2 -> Enoch
+;; ?y1 -> ?y2
+;; (and (son Enoch ?z2)
+;; ((grandson) ?z2 ?y2))
+;; ?z2 -> Irad
+;; ((grandson) Irad ?y2)
+
+;; (assert! (son Adam Cain))
+;; (assert! (son Cain Enoch))
+;; (assert! (son Enoch Irad))
+;; (assert! (son Irad Mehujael))
+;; (assert! (son Mehujael Methushael))
+;; (assert! (son Methushael Lamech))
+;; (assert! (wife Lamech Ada))
+;; (assert! (son Ada Jabal))
+;; (assert! (son Ada Jubal))
+
+(test-query '((great grandson) ?great-grandfather Irad)
+ '(((great grandson) Adam Irad)))
+(test-query '((great great great great great grandson) Adam ?x)
+ '(((great great great great great grandson) Adam Jubal)
+ ((great great great great great grandson) Adam Jabal)))
+
+(test-query '((great grandson) ?g ?ggs)
+ '(((great grandson) mehujael jubal)
+ ((great grandson) irad lamech)
+ ((great grandson) mehujael jabal)
+ ((great grandson) enoch methushael)
+ ((great grandson) cain mehujael)
+ ((great grandson) adam irad)))
+
+;; (test-query '(?relationship Adam Irad))
+;; this goes into an infinite loop
blob - /dev/null
blob + 904029d4ed7dcf667b7089319040712eb2074799 (mode 644)
--- /dev/null
+++ ex4-70.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+
+ ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
+
+(eval-queries
+ '((assert! (rule (ends-in-grandson? (grandson))))
+ (assert! (rule (ends-in-grandson? (?x . ?y))
+ (ends-in-grandson? ?y)))))
+;; (test-query '(ends-in-grandson? (father)))
+;; (test-query '(ends-in-grandson? (son mother father)))
+;; (test-query '(ends-in-grandson? (grandson)))
+;; (test-query '(ends-in-grandson? (father son grandson mother)))
+;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
+
+(eval-queries
+ '((assert! (rule ((great . ?rel) ?x ?y)
+ (and (ends-in-grandson? ?rel)
+ (son ?x ?z)
+ (?rel ?z ?y))))
+ (assert! (rule ((grandson) ?x ?y)
+ (grandson ?x ?y)))))
+
+;; ((great great great grandson) Adam ?somebody)
+;; ((great . ?rel) ?x ?y)
+
+;; ?rel -> (great great grandson)
+;; ?x -> Adam
+;; ?somebody -> ?y
+
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y))
+;; (and (son Adam ?z)
+;; ((great great grandson) ?z ?y))
+
+;; (son Adam ?z)
+;; (son Adam Cain)
+;; ?z -> Cain
+
+;; ((great great grandson) Cain ?y)
+;; ((great . ?rel1) ?x1 ?y1)
+;; ?rel1 -> (great grandson)
+;; ?x1 -> Cain
+;; ?y -> ?y1
+;; (and (son Cain ?z1)
+;; ((great grandson) ?z1 ?y1))
+;; ?z1 -> Enoch
+;; ((great grandson) Enoch ?y1)
+;; ((great . ?rel2) ?x2 ?y2)
+;; ?rel2 -> (grandson)
+;; ?x2 -> Enoch
+;; ?y1 -> ?y2
+;; (and (son Enoch ?z2)
+;; ((grandson) ?z2 ?y2))
+;; ?z2 -> Irad
+;; ((grandson) Irad ?y2)
+
+;; (assert! (son Adam Cain))
+;; (assert! (son Cain Enoch))
+;; (assert! (son Enoch Irad))
+;; (assert! (son Irad Mehujael))
+;; (assert! (son Mehujael Methushael))
+;; (assert! (son Methushael Lamech))
+;; (assert! (wife Lamech Ada))
+;; (assert! (son Ada Jabal))
+;; (assert! (son Ada Jubal))
+
+(test-query '((great grandson) ?great-grandfather Irad)
+ '(((great grandson) Adam Irad)))
+(test-query '((great great great great great grandson) Adam ?x)
+ '(((great great great great great grandson) Adam Jubal)
+ ((great great great great great grandson) Adam Jabal)))
+
+(test-query '((great grandson) ?g ?ggs)
+ '(((great grandson) mehujael jubal)
+ ((great grandson) irad lamech)
+ ((great grandson) mehujael jabal)
+ ((great grandson) enoch methushael)
+ ((great grandson) cain mehujael)
+ ((great grandson) adam irad)))
+
+;; (test-query '(?relationship Adam Irad))
+;; this goes into an infinite loop
+
+;; (?relationship Adam Irad)
+
+;; (rule (ends-in-grandson? (grandson)))
+;; (rule (ends-in-grandson? (?x . ?y))
+;; (ends-in-grandson? ?y))
+;; (rule ((great . ?rel) ?x ?y)
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y)))
+;; (rule ((grandson) ?x ?y)
+;; (grandson ?x ?y))
+
+;; (?relationship Adam Irad)
+;; ((grandson) ?x ?y)
+;; ?relationship -> (grandson)
+;; ?x -> Adam
+;; ?y -> Irad
+
+;; (grandson Adam Irad) -- fails
+
+;; (?relationship Adam Irad)
+;; ((great . ?rel) ?x ?y)
+;; ?relationship -> (great . ?rel)
+;; ?x -> Adam
+;; ?y -> Irad
+
+;; (and (ends-in-grandson? (great . ?rel))
+;; (son Adam ?z)
+;; (?rel ?z Irad))
+
+;; (ends-in-grandson? (great . ?rel))
+;; (ends-in-grandson? (?x1 . ?y1))
+
+;; ?x1 -> great
+;; ?rel -> ?y1
+
+;; (ends-in-grandson? ?rel)
blob - /dev/null
blob + d83a5bd3a2ead9ffe7a5d818695c1d81463ef366 (mode 644)
--- /dev/null
+++ ex4-74.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+
+ ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
+
+(eval-queries
+ '((assert! (rule (ends-in-grandson? (grandson))))
+ (assert! (rule (ends-in-grandson? (?x . ?y))
+ (ends-in-grandson? ?y)))))
+;; (test-query '(ends-in-grandson? (father)))
+;; (test-query '(ends-in-grandson? (son mother father)))
+;; (test-query '(ends-in-grandson? (grandson)))
+;; (test-query '(ends-in-grandson? (father son grandson mother)))
+;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
+
+(eval-queries
+ '((assert! (rule ((great . ?rel) ?x ?y)
+ (and (ends-in-grandson? ?rel)
+ (son ?x ?z)
+ (?rel ?z ?y))))
+ (assert! (rule ((grandson) ?x ?y)
+ (grandson ?x ?y)))))
+
+;; ((great great great grandson) Adam ?somebody)
+;; ((great . ?rel) ?x ?y)
+
+;; ?rel -> (great great grandson)
+;; ?x -> Adam
+;; ?somebody -> ?y
+
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y))
+;; (and (son Adam ?z)
+;; ((great great grandson) ?z ?y))
+
+;; (son Adam ?z)
+;; (son Adam Cain)
+;; ?z -> Cain
+
+;; ((great great grandson) Cain ?y)
+;; ((great . ?rel1) ?x1 ?y1)
+;; ?rel1 -> (great grandson)
+;; ?x1 -> Cain
+;; ?y -> ?y1
+;; (and (son Cain ?z1)
+;; ((great grandson) ?z1 ?y1))
+;; ?z1 -> Enoch
+;; ((great grandson) Enoch ?y1)
+;; ((great . ?rel2) ?x2 ?y2)
+;; ?rel2 -> (grandson)
+;; ?x2 -> Enoch
+;; ?y1 -> ?y2
+;; (and (son Enoch ?z2)
+;; ((grandson) ?z2 ?y2))
+;; ?z2 -> Irad
+;; ((grandson) Irad ?y2)
+
+;; (assert! (son Adam Cain))
+;; (assert! (son Cain Enoch))
+;; (assert! (son Enoch Irad))
+;; (assert! (son Irad Mehujael))
+;; (assert! (son Mehujael Methushael))
+;; (assert! (son Methushael Lamech))
+;; (assert! (wife Lamech Ada))
+;; (assert! (son Ada Jabal))
+;; (assert! (son Ada Jubal))
+
+(test-query '((great grandson) ?great-grandfather Irad)
+ '(((great grandson) Adam Irad)))
+(test-query '((great great great great great grandson) Adam ?x)
+ '(((great great great great great grandson) Adam Jubal)
+ ((great great great great great grandson) Adam Jabal)))
+
+(test-query '((great grandson) ?g ?ggs)
+ '(((great grandson) mehujael jubal)
+ ((great grandson) irad lamech)
+ ((great grandson) mehujael jabal)
+ ((great grandson) enoch methushael)
+ ((great grandson) cain mehujael)
+ ((great grandson) adam irad)))
+
+;; (test-query '(?relationship Adam Irad))
+;; this goes into an infinite loop
+
+
+;; Exercise 4.74. Alyssa P. Hacker proposes to use a simpler version of stream-flatmap in negate, lisp-value, and find-assertions. She observes that the procedure that is mapped over the frame stream in these cases always produces either the empty stream or a singleton stream, so no interleaving is needed when combining these streams.
+
+;; a. Fill in the missing expressions in Alyssa's program.
+
+(define (simple-stream-flatmap proc s)
+ (simple-flatten (stream-map proc s)))
+
+(define (simple-flatten stream)
+ (stream-map stream-car
+ (stream-filter (lambda (x) (not (stream-null? x))) stream)))
+
+;; b. Does the query system's behavior change if we change it in this way?
blob - /dev/null
blob + cf07f4fc5b31363c5271f3313ae25a577b31e72c (mode 644)
--- /dev/null
+++ ex4-74.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+
+ ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
+
+(eval-queries
+ '((assert! (rule (ends-in-grandson? (grandson))))
+ (assert! (rule (ends-in-grandson? (?x . ?y))
+ (ends-in-grandson? ?y)))))
+;; (test-query '(ends-in-grandson? (father)))
+;; (test-query '(ends-in-grandson? (son mother father)))
+;; (test-query '(ends-in-grandson? (grandson)))
+;; (test-query '(ends-in-grandson? (father son grandson mother)))
+;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
+
+(eval-queries
+ '((assert! (rule ((great . ?rel) ?x ?y)
+ (and (ends-in-grandson? ?rel)
+ (son ?x ?z)
+ (?rel ?z ?y))))
+ (assert! (rule ((grandson) ?x ?y)
+ (grandson ?x ?y)))))
+
+;; ((great great great grandson) Adam ?somebody)
+;; ((great . ?rel) ?x ?y)
+
+;; ?rel -> (great great grandson)
+;; ?x -> Adam
+;; ?somebody -> ?y
+
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y))
+;; (and (son Adam ?z)
+;; ((great great grandson) ?z ?y))
+
+;; (son Adam ?z)
+;; (son Adam Cain)
+;; ?z -> Cain
+
+;; ((great great grandson) Cain ?y)
+;; ((great . ?rel1) ?x1 ?y1)
+;; ?rel1 -> (great grandson)
+;; ?x1 -> Cain
+;; ?y -> ?y1
+;; (and (son Cain ?z1)
+;; ((great grandson) ?z1 ?y1))
+;; ?z1 -> Enoch
+;; ((great grandson) Enoch ?y1)
+;; ((great . ?rel2) ?x2 ?y2)
+;; ?rel2 -> (grandson)
+;; ?x2 -> Enoch
+;; ?y1 -> ?y2
+;; (and (son Enoch ?z2)
+;; ((grandson) ?z2 ?y2))
+;; ?z2 -> Irad
+;; ((grandson) Irad ?y2)
+
+;; (assert! (son Adam Cain))
+;; (assert! (son Cain Enoch))
+;; (assert! (son Enoch Irad))
+;; (assert! (son Irad Mehujael))
+;; (assert! (son Mehujael Methushael))
+;; (assert! (son Methushael Lamech))
+;; (assert! (wife Lamech Ada))
+;; (assert! (son Ada Jabal))
+;; (assert! (son Ada Jubal))
+
+(test-query '((great grandson) ?great-grandfather Irad)
+ '(((great grandson) Adam Irad)))
+(test-query '((great great great great great grandson) Adam ?x)
+ '(((great great great great great grandson) Adam Jubal)
+ ((great great great great great grandson) Adam Jabal)))
+
+(test-query '((great grandson) ?g ?ggs)
+ '(((great grandson) mehujael jubal)
+ ((great grandson) irad lamech)
+ ((great grandson) mehujael jabal)
+ ((great grandson) enoch methushael)
+ ((great grandson) cain mehujael)
+ ((great grandson) adam irad)))
+
+;; (test-query '(?relationship Adam Irad))
+;; this goes into an infinite loop
blob - /dev/null
blob + a1c849c1d9faac250c09a16fcedc74d7ecea141a (mode 644)
--- /dev/null
+++ ex4-75.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+
+ ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
+
+(eval-queries
+ '((assert! (rule (ends-in-grandson? (grandson))))
+ (assert! (rule (ends-in-grandson? (?x . ?y))
+ (ends-in-grandson? ?y)))))
+;; (test-query '(ends-in-grandson? (father)))
+;; (test-query '(ends-in-grandson? (son mother father)))
+;; (test-query '(ends-in-grandson? (grandson)))
+;; (test-query '(ends-in-grandson? (father son grandson mother)))
+;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
+
+(eval-queries
+ '((assert! (rule ((great . ?rel) ?x ?y)
+ (and (ends-in-grandson? ?rel)
+ (son ?x ?z)
+ (?rel ?z ?y))))
+ (assert! (rule ((grandson) ?x ?y)
+ (grandson ?x ?y)))))
+
+;; ((great great great grandson) Adam ?somebody)
+;; ((great . ?rel) ?x ?y)
+
+;; ?rel -> (great great grandson)
+;; ?x -> Adam
+;; ?somebody -> ?y
+
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y))
+;; (and (son Adam ?z)
+;; ((great great grandson) ?z ?y))
+
+;; (son Adam ?z)
+;; (son Adam Cain)
+;; ?z -> Cain
+
+;; ((great great grandson) Cain ?y)
+;; ((great . ?rel1) ?x1 ?y1)
+;; ?rel1 -> (great grandson)
+;; ?x1 -> Cain
+;; ?y -> ?y1
+;; (and (son Cain ?z1)
+;; ((great grandson) ?z1 ?y1))
+;; ?z1 -> Enoch
+;; ((great grandson) Enoch ?y1)
+;; ((great . ?rel2) ?x2 ?y2)
+;; ?rel2 -> (grandson)
+;; ?x2 -> Enoch
+;; ?y1 -> ?y2
+;; (and (son Enoch ?z2)
+;; ((grandson) ?z2 ?y2))
+;; ?z2 -> Irad
+;; ((grandson) Irad ?y2)
+
+;; (assert! (son Adam Cain))
+;; (assert! (son Cain Enoch))
+;; (assert! (son Enoch Irad))
+;; (assert! (son Irad Mehujael))
+;; (assert! (son Mehujael Methushael))
+;; (assert! (son Methushael Lamech))
+;; (assert! (wife Lamech Ada))
+;; (assert! (son Ada Jabal))
+;; (assert! (son Ada Jubal))
+
+(test-query '((great grandson) ?great-grandfather Irad)
+ '(((great grandson) Adam Irad)))
+(test-query '((great great great great great grandson) Adam ?x)
+ '(((great great great great great grandson) Adam Jubal)
+ ((great great great great great grandson) Adam Jabal)))
+
+(test-query '((great grandson) ?g ?ggs)
+ '(((great grandson) mehujael jubal)
+ ((great grandson) irad lamech)
+ ((great grandson) mehujael jabal)
+ ((great grandson) enoch methushael)
+ ((great grandson) cain mehujael)
+ ((great grandson) adam irad)))
+
+;; (test-query '(?relationship Adam Irad))
+;; this goes into an infinite loop
+(define (simple-stream-flatmap proc s)
+ (simple-flatten (stream-map proc s)))
+
+(define (simple-flatten stream)
+ (stream-map stream-car
+ (stream-filter (lambda (x) (not (stream-null? x))) stream)))
+
+
+ ;; Exercise 4.75. Implement for the query language a new special form called unique. Unique should succeed if there is precisely one item in the data base satisfying a specified query. For example,
+
+(define (uniquely-asserted operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (let ((results-stream
+ (qeval (unique-query operands)
+ (singleton-stream frame))))
+ (if (singleton-stream? results-stream)
+ results-stream
+ the-empty-stream)))
+ frame-stream))
+(define (unique-query operands)
+ (car operands))
+(define (singleton-stream? s)
+ (and (not (stream-null? s))
+ (stream-null? (stream-cdr s))))
+(put 'unique 'qeval uniquely-asserted)
+
+
+
+(test-query '(unique (job ?x (computer wizard)))
+ '((unique (job (Bitdiddle Ben) (computer wizard)))))
+
+;; should print the one-item stream
+;; since Ben is the only computer wizard, and
+
+(test-query '(unique (job ?x (computer programmer)))
+ '())
+
+;; should print the empty stream, since there is more than one computer programmer. Moreover,
+
+(test-query '(and (job ?x ?j)
+ (unique (job ?anyone ?j)))
+ '((and (job (aull dewitt) (administration secretary)) (unique (job (aull dewitt) (administration secretary))))
+ (and (job (cratchet robert) (accounting scrivener)) (unique (job (cratchet robert) (accounting scrivener))))
+ (and (job (scrooge eben) (accounting chief accountant)) (unique (job (scrooge eben) (accounting chief accountant))))
+ (and (job (warbucks oliver) (administration big wheel)) (unique (job (warbucks oliver) (administration big wheel))))
+ (and (job (reasoner louis) (computer programmer trainee)) (unique (job (reasoner louis) (computer programmer trainee))))
+ (and (job (tweakit lem e) (computer technician)) (unique (job (tweakit lem e) (computer technician))))
+ (and (job (bitdiddle ben) (computer wizard)) (unique (job (bitdiddle ben) (computer wizard))))))
+
+;; should list all the jobs that are filled by only one person, and the people who fill them.
+
+;; There are two parts to implementing unique. The first is to write a procedure that handles this special form, and the second is to make qeval dispatch to that procedure. The second part is trivial, since qeval does its dispatching in a data-directed way. If your procedure is called uniquely-asserted, all you need to do is
+
+
+;; and qeval will dispatch to this procedure for every query whose type (car) is the symbol unique.
+
+;; The real problem is to write the procedure uniquely-asserted. This should take as input the contents (cdr) of the unique query, together with a stream of frames. For each frame in the stream, it should use qeval to find the stream of all extensions to the frame that satisfy the given query. Any stream that does not have exactly one item in it should be eliminated. The remaining streams should be passed back to be accumulated into one big stream that is the result of the unique query. This is similar to the implementation of the not special form.
+
+;; Test your implementation by forming a query that lists all people who supervise precisely one person.
+
+(test-query '(and (supervisor ?sub ?sup)
+ (unique (supervisor ?anyone ?sup)))
+ '((and (supervisor (cratchet robert) (scrooge eben)) (unique (supervisor (cratchet robert) (scrooge eben))))
+ (and (supervisor (reasoner louis) (hacker alyssa p)) (unique (supervisor (reasoner louis) (hacker alyssa p))))))
blob - /dev/null
blob + d83a5bd3a2ead9ffe7a5d818695c1d81463ef366 (mode 644)
--- /dev/null
+++ ex4-75.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+
+ ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
+
+(eval-queries
+ '((assert! (rule (ends-in-grandson? (grandson))))
+ (assert! (rule (ends-in-grandson? (?x . ?y))
+ (ends-in-grandson? ?y)))))
+;; (test-query '(ends-in-grandson? (father)))
+;; (test-query '(ends-in-grandson? (son mother father)))
+;; (test-query '(ends-in-grandson? (grandson)))
+;; (test-query '(ends-in-grandson? (father son grandson mother)))
+;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
+
+(eval-queries
+ '((assert! (rule ((great . ?rel) ?x ?y)
+ (and (ends-in-grandson? ?rel)
+ (son ?x ?z)
+ (?rel ?z ?y))))
+ (assert! (rule ((grandson) ?x ?y)
+ (grandson ?x ?y)))))
+
+;; ((great great great grandson) Adam ?somebody)
+;; ((great . ?rel) ?x ?y)
+
+;; ?rel -> (great great grandson)
+;; ?x -> Adam
+;; ?somebody -> ?y
+
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y))
+;; (and (son Adam ?z)
+;; ((great great grandson) ?z ?y))
+
+;; (son Adam ?z)
+;; (son Adam Cain)
+;; ?z -> Cain
+
+;; ((great great grandson) Cain ?y)
+;; ((great . ?rel1) ?x1 ?y1)
+;; ?rel1 -> (great grandson)
+;; ?x1 -> Cain
+;; ?y -> ?y1
+;; (and (son Cain ?z1)
+;; ((great grandson) ?z1 ?y1))
+;; ?z1 -> Enoch
+;; ((great grandson) Enoch ?y1)
+;; ((great . ?rel2) ?x2 ?y2)
+;; ?rel2 -> (grandson)
+;; ?x2 -> Enoch
+;; ?y1 -> ?y2
+;; (and (son Enoch ?z2)
+;; ((grandson) ?z2 ?y2))
+;; ?z2 -> Irad
+;; ((grandson) Irad ?y2)
+
+;; (assert! (son Adam Cain))
+;; (assert! (son Cain Enoch))
+;; (assert! (son Enoch Irad))
+;; (assert! (son Irad Mehujael))
+;; (assert! (son Mehujael Methushael))
+;; (assert! (son Methushael Lamech))
+;; (assert! (wife Lamech Ada))
+;; (assert! (son Ada Jabal))
+;; (assert! (son Ada Jubal))
+
+(test-query '((great grandson) ?great-grandfather Irad)
+ '(((great grandson) Adam Irad)))
+(test-query '((great great great great great grandson) Adam ?x)
+ '(((great great great great great grandson) Adam Jubal)
+ ((great great great great great grandson) Adam Jabal)))
+
+(test-query '((great grandson) ?g ?ggs)
+ '(((great grandson) mehujael jubal)
+ ((great grandson) irad lamech)
+ ((great grandson) mehujael jabal)
+ ((great grandson) enoch methushael)
+ ((great grandson) cain mehujael)
+ ((great grandson) adam irad)))
+
+;; (test-query '(?relationship Adam Irad))
+;; this goes into an infinite loop
+
+
+;; Exercise 4.74. Alyssa P. Hacker proposes to use a simpler version of stream-flatmap in negate, lisp-value, and find-assertions. She observes that the procedure that is mapped over the frame stream in these cases always produces either the empty stream or a singleton stream, so no interleaving is needed when combining these streams.
+
+;; a. Fill in the missing expressions in Alyssa's program.
+
+(define (simple-stream-flatmap proc s)
+ (simple-flatten (stream-map proc s)))
+
+(define (simple-flatten stream)
+ (stream-map stream-car
+ (stream-filter (lambda (x) (not (stream-null? x))) stream)))
+
+;; b. Does the query system's behavior change if we change it in this way?
blob - /dev/null
blob + dd4b5fe5f05b7fe3cc7a889d377a65be4ed462c1 (mode 644)
--- /dev/null
+++ ex4-76.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+;; (define (conjoin conjuncts frame-stream)
+;; (if (empty-conjunction? conjuncts)
+;; frame-stream
+;; (conjoin (rest-conjuncts conjuncts)
+;; (qeval (first-conjunct conjuncts)
+;; frame-stream))))
+;; (put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+
+ ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
+
+(eval-queries
+ '((assert! (rule (ends-in-grandson? (grandson))))
+ (assert! (rule (ends-in-grandson? (?x . ?y))
+ (ends-in-grandson? ?y)))))
+;; (test-query '(ends-in-grandson? (father)))
+;; (test-query '(ends-in-grandson? (son mother father)))
+;; (test-query '(ends-in-grandson? (grandson)))
+;; (test-query '(ends-in-grandson? (father son grandson mother)))
+;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
+
+(eval-queries
+ '((assert! (rule ((great . ?rel) ?x ?y)
+ (and (ends-in-grandson? ?rel)
+ (son ?x ?z)
+ (?rel ?z ?y))))
+ (assert! (rule ((grandson) ?x ?y)
+ (grandson ?x ?y)))))
+
+;; ((great great great grandson) Adam ?somebody)
+;; ((great . ?rel) ?x ?y)
+
+;; ?rel -> (great great grandson)
+;; ?x -> Adam
+;; ?somebody -> ?y
+
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y))
+;; (and (son Adam ?z)
+;; ((great great grandson) ?z ?y))
+
+;; (son Adam ?z)
+;; (son Adam Cain)
+;; ?z -> Cain
+
+;; ((great great grandson) Cain ?y)
+;; ((great . ?rel1) ?x1 ?y1)
+;; ?rel1 -> (great grandson)
+;; ?x1 -> Cain
+;; ?y -> ?y1
+;; (and (son Cain ?z1)
+;; ((great grandson) ?z1 ?y1))
+;; ?z1 -> Enoch
+;; ((great grandson) Enoch ?y1)
+;; ((great . ?rel2) ?x2 ?y2)
+;; ?rel2 -> (grandson)
+;; ?x2 -> Enoch
+;; ?y1 -> ?y2
+;; (and (son Enoch ?z2)
+;; ((grandson) ?z2 ?y2))
+;; ?z2 -> Irad
+;; ((grandson) Irad ?y2)
+
+;; (assert! (son Adam Cain))
+;; (assert! (son Cain Enoch))
+;; (assert! (son Enoch Irad))
+;; (assert! (son Irad Mehujael))
+;; (assert! (son Mehujael Methushael))
+;; (assert! (son Methushael Lamech))
+;; (assert! (wife Lamech Ada))
+;; (assert! (son Ada Jabal))
+;; (assert! (son Ada Jubal))
+
+(test-query '((great grandson) ?great-grandfather Irad)
+ '(((great grandson) Adam Irad)))
+(test-query '((great great great great great grandson) Adam ?x)
+ '(((great great great great great grandson) Adam Jubal)
+ ((great great great great great grandson) Adam Jabal)))
+
+(test-query '((great grandson) ?g ?ggs)
+ '(((great grandson) mehujael jubal)
+ ((great grandson) irad lamech)
+ ((great grandson) mehujael jabal)
+ ((great grandson) enoch methushael)
+ ((great grandson) cain mehujael)
+ ((great grandson) adam irad)))
+
+;; (test-query '(?relationship Adam Irad))
+;; this goes into an infinite loop
+(define (simple-stream-flatmap proc s)
+ (simple-flatten (stream-map proc s)))
+
+(define (simple-flatten stream)
+ (stream-map stream-car
+ (stream-filter (lambda (x) (not (stream-null? x))) stream)))
+
+
+ ;; Exercise 4.75. Implement for the query language a new special form called unique. Unique should succeed if there is precisely one item in the data base satisfying a specified query. For example,
+
+(define (uniquely-asserted operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (let ((results-stream
+ (qeval (unique-query operands)
+ (singleton-stream frame))))
+ (if (singleton-stream? results-stream)
+ results-stream
+ the-empty-stream)))
+ frame-stream))
+(define (unique-query operands)
+ (car operands))
+(define (singleton-stream? s)
+ (and (not (stream-null? s))
+ (stream-null? (stream-cdr s))))
+(put 'unique 'qeval uniquely-asserted)
+
+(test-query '(unique (job ?x (computer wizard)))
+ '((unique (job (Bitdiddle Ben) (computer wizard)))))
+(test-query '(unique (job ?x (computer programmer)))
+ '())
+(test-query '(and (job ?x ?j)
+ (unique (job ?anyone ?j)))
+ '((and (job (aull dewitt) (administration secretary)) (unique (job (aull dewitt) (administration secretary))))
+ (and (job (cratchet robert) (accounting scrivener)) (unique (job (cratchet robert) (accounting scrivener))))
+ (and (job (scrooge eben) (accounting chief accountant)) (unique (job (scrooge eben) (accounting chief accountant))))
+ (and (job (warbucks oliver) (administration big wheel)) (unique (job (warbucks oliver) (administration big wheel))))
+ (and (job (reasoner louis) (computer programmer trainee)) (unique (job (reasoner louis) (computer programmer trainee))))
+ (and (job (tweakit lem e) (computer technician)) (unique (job (tweakit lem e) (computer technician))))
+ (and (job (bitdiddle ben) (computer wizard)) (unique (job (bitdiddle ben) (computer wizard))))))
+(test-query '(and (supervisor ?sub ?sup)
+ (unique (supervisor ?anyone ?sup)))
+ '((and (supervisor (cratchet robert) (scrooge eben)) (unique (supervisor (cratchet robert) (scrooge eben))))
+ (and (supervisor (reasoner louis) (hacker alyssa p)) (unique (supervisor (reasoner louis) (hacker alyssa p))))))
+
+;; Exercise 4.76. Our implementation of and as a series combination of queries (figure 4.5) is elegant, but it is inefficient because in processing the second query of the and we must scan the data base for each frame produced by the first query. If the data base has N elements, and a typical query produces a number of output frames proportional to N (say N/k), then scanning the data base for each frame produced by the first query will require N2/k calls to the pattern matcher. Another approach would be to process the two clauses of the and separately, then look for all pairs of output frames that are compatible. If each query produces N/k output frames, then this means that we must perform N2/k2 compatibility checks -- a factor of k fewer than the number of matches required in our current method.
+
+;; Devise an implementation of and that uses this strategy. You must implement a procedure that takes two frames as inputs, checks whether the bindings in the frames are compatible, and, if so, produces a frame that merges the two sets of bindings. This operation is similar to unification.
+
+;; returns merged frame or 'failed
+(define (merge-frame frame1 frame2)
+ (if (null? frame1)
+ frame2
+ (let* ((binding (first-binding frame1))
+ (var (binding-variable binding))
+ (val (binding-value binding))
+ (merged-result (extend-if-possible var val frame2)))
+ (if (eq? merged-result 'failed)
+ 'failed
+ (merge-frame (rest-bindings frame1) frame2)))))
+
+;; returns stream of frames that can be merged
+(define (merge-streams s1 s2)
+ (stream-flatmap
+ (lambda (f1)
+ (stream-flatmap
+ (lambda (f2)
+ (let ((merged-frame (merge-frame f1 f2)))
+ (if (eq? merged-frame 'failed)
+ the-empty-stream
+ (singleton-stream merged-frame))))
+ s2))
+ s1))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (merge-streams
+ (qeval (first-conjunct conjuncts) frame-stream)
+ (conjoin (rest-conjuncts conjuncts) frame-stream))))
+
+(define (first-binding frame)
+ (car frame))
+(define (rest-bindings frame)
+ (cdr frame))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
blob - /dev/null
blob + a1c849c1d9faac250c09a16fcedc74d7ecea141a (mode 644)
--- /dev/null
+++ ex4-76.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+
+ ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
+
+(eval-queries
+ '((assert! (rule (ends-in-grandson? (grandson))))
+ (assert! (rule (ends-in-grandson? (?x . ?y))
+ (ends-in-grandson? ?y)))))
+;; (test-query '(ends-in-grandson? (father)))
+;; (test-query '(ends-in-grandson? (son mother father)))
+;; (test-query '(ends-in-grandson? (grandson)))
+;; (test-query '(ends-in-grandson? (father son grandson mother)))
+;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
+
+(eval-queries
+ '((assert! (rule ((great . ?rel) ?x ?y)
+ (and (ends-in-grandson? ?rel)
+ (son ?x ?z)
+ (?rel ?z ?y))))
+ (assert! (rule ((grandson) ?x ?y)
+ (grandson ?x ?y)))))
+
+;; ((great great great grandson) Adam ?somebody)
+;; ((great . ?rel) ?x ?y)
+
+;; ?rel -> (great great grandson)
+;; ?x -> Adam
+;; ?somebody -> ?y
+
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y))
+;; (and (son Adam ?z)
+;; ((great great grandson) ?z ?y))
+
+;; (son Adam ?z)
+;; (son Adam Cain)
+;; ?z -> Cain
+
+;; ((great great grandson) Cain ?y)
+;; ((great . ?rel1) ?x1 ?y1)
+;; ?rel1 -> (great grandson)
+;; ?x1 -> Cain
+;; ?y -> ?y1
+;; (and (son Cain ?z1)
+;; ((great grandson) ?z1 ?y1))
+;; ?z1 -> Enoch
+;; ((great grandson) Enoch ?y1)
+;; ((great . ?rel2) ?x2 ?y2)
+;; ?rel2 -> (grandson)
+;; ?x2 -> Enoch
+;; ?y1 -> ?y2
+;; (and (son Enoch ?z2)
+;; ((grandson) ?z2 ?y2))
+;; ?z2 -> Irad
+;; ((grandson) Irad ?y2)
+
+;; (assert! (son Adam Cain))
+;; (assert! (son Cain Enoch))
+;; (assert! (son Enoch Irad))
+;; (assert! (son Irad Mehujael))
+;; (assert! (son Mehujael Methushael))
+;; (assert! (son Methushael Lamech))
+;; (assert! (wife Lamech Ada))
+;; (assert! (son Ada Jabal))
+;; (assert! (son Ada Jubal))
+
+(test-query '((great grandson) ?great-grandfather Irad)
+ '(((great grandson) Adam Irad)))
+(test-query '((great great great great great grandson) Adam ?x)
+ '(((great great great great great grandson) Adam Jubal)
+ ((great great great great great grandson) Adam Jabal)))
+
+(test-query '((great grandson) ?g ?ggs)
+ '(((great grandson) mehujael jubal)
+ ((great grandson) irad lamech)
+ ((great grandson) mehujael jabal)
+ ((great grandson) enoch methushael)
+ ((great grandson) cain mehujael)
+ ((great grandson) adam irad)))
+
+;; (test-query '(?relationship Adam Irad))
+;; this goes into an infinite loop
+(define (simple-stream-flatmap proc s)
+ (simple-flatten (stream-map proc s)))
+
+(define (simple-flatten stream)
+ (stream-map stream-car
+ (stream-filter (lambda (x) (not (stream-null? x))) stream)))
+
+
+ ;; Exercise 4.75. Implement for the query language a new special form called unique. Unique should succeed if there is precisely one item in the data base satisfying a specified query. For example,
+
+(define (uniquely-asserted operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (let ((results-stream
+ (qeval (unique-query operands)
+ (singleton-stream frame))))
+ (if (singleton-stream? results-stream)
+ results-stream
+ the-empty-stream)))
+ frame-stream))
+(define (unique-query operands)
+ (car operands))
+(define (singleton-stream? s)
+ (and (not (stream-null? s))
+ (stream-null? (stream-cdr s))))
+(put 'unique 'qeval uniquely-asserted)
+
+
+
+(test-query '(unique (job ?x (computer wizard)))
+ '((unique (job (Bitdiddle Ben) (computer wizard)))))
+
+;; should print the one-item stream
+;; since Ben is the only computer wizard, and
+
+(test-query '(unique (job ?x (computer programmer)))
+ '())
+
+;; should print the empty stream, since there is more than one computer programmer. Moreover,
+
+(test-query '(and (job ?x ?j)
+ (unique (job ?anyone ?j)))
+ '((and (job (aull dewitt) (administration secretary)) (unique (job (aull dewitt) (administration secretary))))
+ (and (job (cratchet robert) (accounting scrivener)) (unique (job (cratchet robert) (accounting scrivener))))
+ (and (job (scrooge eben) (accounting chief accountant)) (unique (job (scrooge eben) (accounting chief accountant))))
+ (and (job (warbucks oliver) (administration big wheel)) (unique (job (warbucks oliver) (administration big wheel))))
+ (and (job (reasoner louis) (computer programmer trainee)) (unique (job (reasoner louis) (computer programmer trainee))))
+ (and (job (tweakit lem e) (computer technician)) (unique (job (tweakit lem e) (computer technician))))
+ (and (job (bitdiddle ben) (computer wizard)) (unique (job (bitdiddle ben) (computer wizard))))))
+
+;; should list all the jobs that are filled by only one person, and the people who fill them.
+
+;; There are two parts to implementing unique. The first is to write a procedure that handles this special form, and the second is to make qeval dispatch to that procedure. The second part is trivial, since qeval does its dispatching in a data-directed way. If your procedure is called uniquely-asserted, all you need to do is
+
+
+;; and qeval will dispatch to this procedure for every query whose type (car) is the symbol unique.
+
+;; The real problem is to write the procedure uniquely-asserted. This should take as input the contents (cdr) of the unique query, together with a stream of frames. For each frame in the stream, it should use qeval to find the stream of all extensions to the frame that satisfy the given query. Any stream that does not have exactly one item in it should be eliminated. The remaining streams should be passed back to be accumulated into one big stream that is the result of the unique query. This is similar to the implementation of the not special form.
+
+;; Test your implementation by forming a query that lists all people who supervise precisely one person.
+
+(test-query '(and (supervisor ?sub ?sup)
+ (unique (supervisor ?anyone ?sup)))
+ '((and (supervisor (cratchet robert) (scrooge eben)) (unique (supervisor (cratchet robert) (scrooge eben))))
+ (and (supervisor (reasoner louis) (hacker alyssa p)) (unique (supervisor (reasoner louis) (hacker alyssa p))))))
blob - /dev/null
blob + ca009f8a1d94289449785a40fa8aa44c82522512 (mode 644)
--- /dev/null
+++ ex4-76b.scm
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (conjoin (rest-conjuncts conjuncts)
+ (qeval (first-conjunct conjuncts)
+ frame-stream))))
+(put 'and 'qeval conjoin)
+
+
+;; Exercise 4.76. Our implementation of and as a series combination of queries (figure 4.5) is elegant, but it is inefficient because in processing the second query of the and we must scan the data base for each frame produced by the first query. If the data base has N elements, and a typical query produces a number of output frames proportional to N (say N/k), then scanning the data base for each frame produced by the first query will require N2/k calls to the pattern matcher. Another approach would be to process the two clauses of the and separately, then look for all pairs of output frames that are compatible. If each query produces N/k output frames, then this means that we must perform N2/k2 compatibility checks -- a factor of k fewer than the number of matches required in our current method.
+
+;; Devise an implementation of and that uses this strategy. You must implement a procedure that takes two frames as inputs, checks whether the bindings in the frames are compatible, and, if so, produces a frame that merges the two sets of bindings. This operation is similar to unification.
+
+;; returns merged frame or 'failed
+(define (merge-frame frame1 frame2)
+ (if (null? frame1)
+ frame2
+ (let* ((binding (first-binding frame1))
+ (var (binding-variable binding))
+ (val (binding-value binding))
+ (merged-result (extend-if-possible var val frame2)))
+ (if (eq? merged-result 'failed)
+ 'failed
+ (merge-frame (rest-bindings frame1) frame2)))))
+
+;; returns stream of frames that can be merged
+(define (merge-streams s1 s2)
+ (stream-flatmap
+ (lambda (f1)
+ (stream-flatmap
+ (lambda (f2)
+ (let ((merged-frame (merge-frame f1 f2)))
+ (if (eq? merged-frame 'failed)
+ the-empty-stream
+ (singleton-stream merged-frame))))
+ s2))
+ s1))
+;; (define (conjoin conjuncts frame-stream)
+;; (if (empty-conjunction? conjuncts)
+;; frame-stream
+;; (merge-streams
+;; (qeval (first-conjunct conjuncts) frame-stream)
+;; (conjoin (rest-conjuncts conjuncts) frame-stream))))
+
+(define (first-binding frame)
+ (car frame))
+(define (rest-bindings frame)
+ (cdr frame))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+
+
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (display-streams
+ (length list)
+ (eval-query query)
+ (list->stream list)))))
+
+ ;; (let ((list (car expected)))
+ ;; (let ((result
+ ;; (stream-fold-left
+ ;; (lambda (x y)
+ ;; (and x y))
+ ;; #t
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+ ;; (if result
+ ;; (display "Passed -- ")
+ ;; (display "Failed! -- "))
+ ;; (display query)
+ ;; (newline)))))
+
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+
+ ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
+
+(eval-queries
+ '((assert! (rule (ends-in-grandson? (grandson))))
+ (assert! (rule (ends-in-grandson? (?x . ?y))
+ (ends-in-grandson? ?y)))))
+;; (test-query '(ends-in-grandson? (father)))
+;; (test-query '(ends-in-grandson? (son mother father)))
+;; (test-query '(ends-in-grandson? (grandson)))
+;; (test-query '(ends-in-grandson? (father son grandson mother)))
+;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
+
+(eval-queries
+ '((assert! (rule ((great . ?rel) ?x ?y)
+ (and (ends-in-grandson? ?rel)
+ (son ?x ?z)
+ (?rel ?z ?y))))
+ (assert! (rule ((grandson) ?x ?y)
+ (grandson ?x ?y)))))
+
+;; ((great great great grandson) Adam ?somebody)
+;; ((great . ?rel) ?x ?y)
+
+;; ?rel -> (great great grandson)
+;; ?x -> Adam
+;; ?somebody -> ?y
+
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y))
+;; (and (son Adam ?z)
+;; ((great great grandson) ?z ?y))
+
+;; (son Adam ?z)
+;; (son Adam Cain)
+;; ?z -> Cain
+
+;; ((great great grandson) Cain ?y)
+;; ((great . ?rel1) ?x1 ?y1)
+;; ?rel1 -> (great grandson)
+;; ?x1 -> Cain
+;; ?y -> ?y1
+;; (and (son Cain ?z1)
+;; ((great grandson) ?z1 ?y1))
+;; ?z1 -> Enoch
+;; ((great grandson) Enoch ?y1)
+;; ((great . ?rel2) ?x2 ?y2)
+;; ?rel2 -> (grandson)
+;; ?x2 -> Enoch
+;; ?y1 -> ?y2
+;; (and (son Enoch ?z2)
+;; ((grandson) ?z2 ?y2))
+;; ?z2 -> Irad
+;; ((grandson) Irad ?y2)
+
+;; (assert! (son Adam Cain))
+;; (assert! (son Cain Enoch))
+;; (assert! (son Enoch Irad))
+;; (assert! (son Irad Mehujael))
+;; (assert! (son Mehujael Methushael))
+;; (assert! (son Methushael Lamech))
+;; (assert! (wife Lamech Ada))
+;; (assert! (son Ada Jabal))
+;; (assert! (son Ada Jubal))
+
+(test-query '((great grandson) ?great-grandfather Irad)
+ '(((great grandson) Adam Irad)))
+(test-query '((great great great great great grandson) Adam ?x)
+ '(((great great great great great grandson) Adam Jubal)
+ ((great great great great great grandson) Adam Jabal)))
+
+(test-query '((great grandson) ?g ?ggs)
+ '(((great grandson) mehujael jubal)
+ ((great grandson) irad lamech)
+ ((great grandson) mehujael jabal)
+ ((great grandson) enoch methushael)
+ ((great grandson) cain mehujael)
+ ((great grandson) adam irad)))
+
+;; (test-query '(?relationship Adam Irad))
+;; this goes into an infinite loop
+(define (simple-stream-flatmap proc s)
+ (simple-flatten (stream-map proc s)))
+
+(define (simple-flatten stream)
+ (stream-map stream-car
+ (stream-filter (lambda (x) (not (stream-null? x))) stream)))
+
+
+ ;; Exercise 4.75. Implement for the query language a new special form called unique. Unique should succeed if there is precisely one item in the data base satisfying a specified query. For example,
+
+(define (uniquely-asserted operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (let ((results-stream
+ (qeval (unique-query operands)
+ (singleton-stream frame))))
+ (if (singleton-stream? results-stream)
+ results-stream
+ the-empty-stream)))
+ frame-stream))
+(define (unique-query operands)
+ (car operands))
+(define (singleton-stream? s)
+ (and (not (stream-null? s))
+ (stream-null? (stream-cdr s))))
+(put 'unique 'qeval uniquely-asserted)
+
+(test-query '(unique (job ?x (computer wizard)))
+ '((unique (job (Bitdiddle Ben) (computer wizard)))))
+(test-query '(unique (job ?x (computer programmer)))
+ '())
+(test-query '(and (job ?x ?j)
+ (unique (job ?anyone ?j)))
+ '((and (job (aull dewitt) (administration secretary)) (unique (job (aull dewitt) (administration secretary))))
+ (and (job (cratchet robert) (accounting scrivener)) (unique (job (cratchet robert) (accounting scrivener))))
+ (and (job (scrooge eben) (accounting chief accountant)) (unique (job (scrooge eben) (accounting chief accountant))))
+ (and (job (warbucks oliver) (administration big wheel)) (unique (job (warbucks oliver) (administration big wheel))))
+ (and (job (reasoner louis) (computer programmer trainee)) (unique (job (reasoner louis) (computer programmer trainee))))
+ (and (job (tweakit lem e) (computer technician)) (unique (job (tweakit lem e) (computer technician))))
+ (and (job (bitdiddle ben) (computer wizard)) (unique (job (bitdiddle ben) (computer wizard))))))
+(test-query '(and (supervisor ?sub ?sup)
+ (unique (supervisor ?anyone ?sup)))
+ '((and (supervisor (cratchet robert) (scrooge eben)) (unique (supervisor (cratchet robert) (scrooge eben))))
+ (and (supervisor (reasoner louis) (hacker alyssa p)) (unique (supervisor (reasoner louis) (hacker alyssa p))))))
blob - /dev/null
blob + dd4b5fe5f05b7fe3cc7a889d377a65be4ed462c1 (mode 644)
--- /dev/null
+++ ex4-76b.scm~
+
+;; dispatch table
+
+(define (make-table)
+ (define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records)))))
+ (let ((local-table (list '*table*)))
+ (define (lookup key-1 key-2)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (cdr record)
+ false))
+ false)))
+ (define (insert! key-1 key-2 value)
+ (let ((subtable (assoc key-1 (cdr local-table))))
+ (if subtable
+ (let ((record (assoc key-2 (cdr subtable))))
+ (if record
+ (set-cdr! record value)
+ (set-cdr! subtable
+ (cons (cons key-2 value)
+ (cdr subtable)))))
+ (set-cdr! local-table
+ (cons (list key-1
+ (cons key-2 value))
+ (cdr local-table)))))
+ 'ok)
+ (define (dispatch m)
+ (cond ((eq? m 'lookup-proc) lookup)
+ ((eq? m 'insert-proc!) insert!)
+ (else (error "Unknown operation -- TABLE" m))))
+ dispatch))
+(define operation-table (make-table))
+(define get (operation-table 'lookup-proc))
+(define put (operation-table 'insert-proc!))
+
+;; streams/delayed-evaluation
+
+(define (memo-proc proc)
+ (let ((already-run? false) (result false))
+ (lambda ()
+ (if already-run?
+ result
+ (begin (set! already-run? true)
+ (set! result (proc))
+ result)))))
+(define-syntax mydelay
+ (rsc-macro-transformer
+ (let ((xfmr
+ (lambda (exp)
+ `(memo-proc (lambda () ,exp)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (myforce delayed-object)
+ (delayed-object))
+(define-syntax cons-stream
+ (rsc-macro-transformer
+ (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
+ (lambda (e r)
+ (apply xfmr (cdr e))))))
+(define (stream-car s)
+ (car s))
+(define (stream-cdr s)
+ (myforce (cdr s)))
+(define stream-null? null?)
+(define the-empty-stream '())
+(define (stream-map proc . argstreams)
+ (if (stream-null? (car argstreams))
+ the-empty-stream
+ (cons-stream
+ (apply proc (map stream-car argstreams))
+ (apply stream-map (cons proc (map stream-cdr argstreams))))))
+(define (display-stream s)
+ (stream-for-each display-line s))
+(define (stream-for-each proc s)
+ (if (stream-null? s)
+ 'done
+ (begin (proc (stream-car s))
+ (stream-for-each proc (stream-cdr s)))))
+(define (display-line x)
+ (newline)
+ (display x))
+(define (display-streams n . streams)
+ (if (> n 0)
+ (begin (newline)
+ (for-each
+ (lambda (s)
+ (display (stream-car s))
+ (newline))
+ streams)
+ (apply display-streams
+ (cons (- n 1) (map stream-cdr streams))))))
+(define (list->stream list)
+ (if (null? list)
+ the-empty-stream
+ (cons-stream (car list)
+ (list->stream (cdr list)))))
+(define (stream-fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (stream-car rest))
+ (stream-cdr rest))))
+ (iter initial sequence))
+
+;; query-driver-loop
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+(define (query-driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((q (query-syntax-process (read))))
+ (cond ((assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (newline)
+ (display "Assertion added to data base.")
+ (query-driver-loop))
+ (else
+ (newline)
+ (display output-prompt)
+ (display-stream
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))
+ (query-driver-loop)))))
+(define (instantiate exp frame unbound-var-handler)
+ (define (copy exp)
+ (cond ((var? exp)
+ (let ((binding (binding-in-frame exp frame)))
+ (if binding
+ (copy (binding-value binding))
+ (unbound-var-handler exp frame))))
+ ((pair? exp)
+ (cons (copy (car exp)) (copy (cdr exp))))
+ (else exp)))
+ (copy exp))
+(define (qeval query frame-stream)
+ (let ((qproc (get (type query) 'qeval)))
+ (if qproc
+ (qproc (contents query) frame-stream)
+ (simple-query query frame-stream))))
+(define (simple-query query-pattern frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (stream-append-delayed
+ (find-assertions query-pattern frame)
+ (delay (apply-rules query-pattern frame))))
+ frame-stream))
+;; (define (conjoin conjuncts frame-stream)
+;; (if (empty-conjunction? conjuncts)
+;; frame-stream
+;; (conjoin (rest-conjuncts conjuncts)
+;; (qeval (first-conjunct conjuncts)
+;; frame-stream))))
+;; (put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame-stream)
+ (if (empty-disjunction? disjuncts)
+ the-empty-stream
+ (interleave-delayed
+ (qeval (first-disjunct disjuncts) frame-stream)
+ (delay (disjoin (rest-disjuncts disjuncts)
+ frame-stream)))))
+(put 'or 'qeval disjoin)
+(define (negate operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (stream-null? (qeval (negated-query operands)
+ (singleton-stream frame)))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'not 'qeval negate)
+(define (lisp-value call frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (if (execute
+ (instantiate
+ call
+ frame
+ (lambda (v f)
+ (error "Unknown pat var -- LISP-VALUE" v))))
+ (singleton-stream frame)
+ the-empty-stream))
+ frame-stream))
+(put 'lisp-value 'qeval lisp-value)
+(define (execute exp)
+ (apply (eval (predicate exp) user-initial-environment)
+ (args exp)))
+(define (always-true ignore frame-stream) frame-stream)
+(put 'always-true 'qeval always-true)
+(define (find-assertions pattern frame)
+ (stream-flatmap (lambda (datum)
+ (check-an-assertion datum pattern frame))
+ (fetch-assertions pattern frame)))
+(define (check-an-assertion assertion query-pat query-frame)
+ (let ((match-result
+ (pattern-match query-pat assertion query-frame)))
+ (if (eq? match-result 'failed)
+ the-empty-stream
+ (singleton-stream match-result))))
+(define (pattern-match pat dat frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? pat dat) frame)
+ ((var? pat) (extend-if-consistent pat dat frame))
+ ((and (pair? pat) (pair? dat))
+ (pattern-match (cdr pat)
+ (cdr dat)
+ (pattern-match (car pat)
+ (car dat)
+ frame)))
+ (else 'failed)))
+(define (extend-if-consistent var dat frame)
+ (let ((binding (binding-in-frame var frame)))
+ (if binding
+ (pattern-match (binding-value binding) dat frame)
+ (extend var dat frame))))
+(define (apply-rules pattern frame)
+ (stream-flatmap (lambda (rule)
+ (apply-a-rule rule pattern frame))
+ (fetch-rules pattern frame)))
+(define (apply-a-rule rule query-pattern query-frame)
+ (let ((clean-rule (rename-variables-in rule)))
+ (let ((unify-result
+ (unify-match query-pattern
+ (conclusion clean-rule)
+ query-frame)))
+ (if (eq? unify-result 'failed)
+ the-empty-stream
+ (qeval (rule-body clean-rule)
+ (singleton-stream unify-result))))))
+(define (rename-variables-in rule)
+ (let ((rule-application-id (new-rule-application-id)))
+ (define (tree-walk exp)
+ (cond ((var? exp)
+ (make-new-variable exp rule-application-id))
+ ((pair? exp)
+ (cons (tree-walk (car exp))
+ (tree-walk (cdr exp))))
+ (else exp)))
+ (tree-walk rule)))
+(define (unify-match p1 p2 frame)
+ (cond ((eq? frame 'failed) 'failed)
+ ((equal? p1 p2) frame)
+ ((var? p1) (extend-if-possible p1 p2 frame))
+ ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
+ ((and (pair? p1) (pair? p2))
+ (unify-match (cdr p1)
+ (cdr p2)
+ (unify-match (car p1)
+ (car p2)
+ frame)))
+ (else 'failed)))
+(define (extend-if-possible var val frame)
+ (let ((binding (binding-in-frame var frame)))
+ (cond (binding
+ (unify-match
+ (binding-value binding) val frame))
+ ((var? val) ; ***
+ (let ((binding (binding-in-frame val frame)))
+ (if binding
+ (unify-match
+ var (binding-value binding) frame)
+ (extend var val frame))))
+ ((depends-on? val var frame) ; ***
+ 'failed)
+ (else (extend var val frame)))))
+(define (depends-on? exp var frame)
+ (define (tree-walk e)
+ (cond ((var? e)
+ (if (equal? var e)
+ true
+ (let ((b (binding-in-frame e frame)))
+ (if b
+ (tree-walk (binding-value b))
+ false))))
+ ((pair? e)
+ (or (tree-walk (car e))
+ (tree-walk (cdr e))))
+ (else false)))
+ (tree-walk exp))
+(define THE-ASSERTIONS the-empty-stream)
+(define (fetch-assertions pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-assertions pattern)
+ (get-all-assertions)))
+(define (get-all-assertions) THE-ASSERTIONS)
+(define (get-indexed-assertions pattern)
+ (get-stream (index-key-of pattern) 'assertion-stream))
+(define (get-stream key1 key2)
+ (let ((s (get key1 key2)))
+ (if s s the-empty-stream)))
+(define THE-RULES the-empty-stream)
+(define (fetch-rules pattern frame)
+ (if (use-index? pattern)
+ (get-indexed-rules pattern)
+ (get-all-rules)))
+(define (get-all-rules) THE-RULES)
+(define (get-indexed-rules pattern)
+ (stream-append
+ (get-stream (index-key-of pattern) 'rule-stream)
+ (get-stream '? 'rule-stream)))
+(define (add-rule-or-assertion! assertion)
+ (if (rule? assertion)
+ (add-rule! assertion)
+ (add-assertion! assertion)))
+(define (add-assertion! assertion)
+ (store-assertion-in-index assertion)
+ (let ((old-assertions THE-ASSERTIONS))
+ (set! THE-ASSERTIONS
+ (cons-stream assertion old-assertions))
+ 'ok))
+(define (add-rule! rule)
+ (store-rule-in-index rule)
+ (let ((old-rules THE-RULES))
+ (set! THE-RULES (cons-stream rule old-rules))
+ 'ok))
+(define (store-assertion-in-index assertion)
+ (if (indexable? assertion)
+ (let ((key (index-key-of assertion)))
+ (let ((current-assertion-stream
+ (get-stream key 'assertion-stream)))
+ (put key
+ 'assertion-stream
+ (cons-stream assertion
+ current-assertion-stream))))))
+(define (store-rule-in-index rule)
+ (let ((pattern (conclusion rule)))
+ (if (indexable? pattern)
+ (let ((key (index-key-of pattern)))
+ (let ((current-rule-stream
+ (get-stream key 'rule-stream)))
+ (put key
+ 'rule-stream
+ (cons-stream rule
+ current-rule-stream)))))))
+(define (indexable? pat)
+ (or (constant-symbol? (car pat))
+ (var? (car pat))))
+(define (index-key-of pat)
+ (let ((key (car pat)))
+ (if (var? key) '? key)))
+(define (use-index? pat)
+ (constant-symbol? (car pat)))
+(define (stream-append s1 s2)
+ (if (stream-null? s1)
+ s2
+ (cons-stream (stream-car s1)
+ (stream-append (stream-cdr s1) s2))))
+(define (stream-append-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (stream-append-delayed (stream-cdr s1) delayed-s2))))
+(define (interleave-delayed s1 delayed-s2)
+ (if (stream-null? s1)
+ (force delayed-s2)
+ (cons-stream
+ (stream-car s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (stream-cdr s1))))))
+(define (stream-flatmap proc s)
+ (flatten-stream (stream-map proc s)))
+(define (flatten-stream stream)
+ (if (stream-null? stream)
+ the-empty-stream
+ (interleave-delayed
+ (stream-car stream)
+ (delay (flatten-stream (stream-cdr stream))))))
+(define (singleton-stream x)
+ (cons-stream x the-empty-stream))
+(define (type exp)
+ (if (pair? exp)
+ (car exp)
+ (error "Unknown expression TYPE" exp)))
+(define (contents exp)
+ (if (pair? exp)
+ (cdr exp)
+ (error "Unknown expression CONTENTS" exp)))
+(define (assertion-to-be-added? exp)
+ (eq? (type exp) 'assert!))
+(define (add-assertion-body exp)
+ (car (contents exp)))
+(define (empty-conjunction? exps) (null? exps))
+(define (first-conjunct exps) (car exps))
+(define (rest-conjuncts exps) (cdr exps))
+(define (empty-disjunction? exps) (null? exps))
+(define (first-disjunct exps) (car exps))
+(define (rest-disjuncts exps) (cdr exps))
+(define (negated-query exps) (car exps))
+(define (predicate exps) (car exps))
+(define (args exps) (cdr exps))
+(define (rule? statement)
+ (tagged-list? statement 'rule))
+(define (conclusion rule) (cadr rule))
+(define (rule-body rule)
+ (if (null? (cddr rule))
+ '(always-true)
+ (caddr rule)))
+(define (query-syntax-process exp)
+ (map-over-symbols expand-question-mark exp))
+(define (map-over-symbols proc exp)
+ (cond ((pair? exp)
+ (cons (map-over-symbols proc (car exp))
+ (map-over-symbols proc (cdr exp))))
+ ((symbol? exp) (proc exp))
+ (else exp)))
+(define (expand-question-mark symbol)
+ (let ((chars (symbol->string symbol)))
+ (if (string=? (substring chars 0 1) "?")
+ (list '?
+ (string->symbol
+ (substring chars 1 (string-length chars))))
+ symbol)))
+(define (var? exp)
+ (tagged-list? exp '?))
+(define (constant-symbol? exp) (symbol? exp))
+(define rule-counter 0)
+(define (new-rule-application-id)
+ (set! rule-counter (+ 1 rule-counter))
+ rule-counter)
+(define (make-new-variable var rule-application-id)
+ (cons '? (cons rule-application-id (cdr var))))
+(define (contract-question-mark variable)
+ (string->symbol
+ (string-append "?"
+ (if (number? (cadr variable))
+ (string-append (symbol->string (caddr variable))
+ "-"
+ (number->string (cadr variable)))
+ (symbol->string (cadr variable))))))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+
+;; test procedures
+
+(define (eval-queries queries)
+ (if (null? queries)
+ 'done
+ (begin (eval-query (car queries))
+ (eval-queries (cdr queries)))))
+(define (eval-query query)
+ (let ((q (query-syntax-process query)))
+ (if (assertion-to-be-added? q)
+ (add-rule-or-assertion! (add-assertion-body q))
+ (stream-map
+ (lambda (frame)
+ (instantiate q
+ frame
+ (lambda (v f)
+ (contract-question-mark v))))
+ (qeval q (singleton-stream '()))))))
+(define (eval-display-query q)
+ (display-stream (eval-query q)))
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (test-query query . expected)
+ (if (null? expected)
+ (let ((result (eval-query query)))
+ (if (symbol? result)
+ (begin (display "Assertion added") (newline))
+ (display-stream (eval-query query))))
+ (let ((list (car expected)))
+ (let ((result
+ (stream-fold-left
+ (lambda (x y)
+ (and x y))
+ #t
+ (stream-map
+ (lambda (e1 e2)
+ (equal? e1 e2))
+ (eval-query query)
+ (list->stream list)))))
+ (if result
+ (display "Passed -- ")
+ (display "Failed! -- "))
+ (display query)
+ (newline)))))
+
+ ;; (let ((result (eval-query query)))
+ ;; (if (pair? result)
+ ;; (display-stream (eval-query query))
+ ;; result))
+
+;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
+
+ ;; (display-streams
+ ;; (length list)
+ ;; (eval-query query)
+ ;; (list->stream list)))))
+
+ ;; (display-stream
+ ;; (stream-map
+ ;; (lambda (e1 e2)
+ ;; (equal? e1 e2))
+ ;; (eval-query query)
+ ;; (list->stream list))))))
+;; test-suite
+
+
+(eval-queries
+'((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
+ (assert! (job (Bitdiddle Ben) (computer wizard)))
+ (assert! (salary (Bitdiddle Ben) 60000))
+ (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
+ (assert! (job (Hacker Alyssa P) (computer programmer)))
+ (assert! (salary (Hacker Alyssa P) 40000))
+ (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
+ (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
+ (assert! (job (Fect Cy D) (computer programmer)))
+ (assert! (salary (Fect Cy D) 35000))
+ (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
+ (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
+ (assert! (job (Tweakit Lem E) (computer technician)))
+ (assert! (salary (Tweakit Lem E) 25000))
+ (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
+ (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
+ (assert! (job (Reasoner Louis) (computer programmer trainee)))
+ (assert! (salary (Reasoner Louis) 30000))
+ (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
+ (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
+ (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
+ (assert! (job (Warbucks Oliver) (administration big wheel)))
+ (assert! (salary (Warbucks Oliver) 150000))
+ (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
+ (assert! (job (Scrooge Eben) (accounting chief accountant)))
+ (assert! (salary (Scrooge Eben) 75000))
+ (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
+ (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
+ (assert! (job (Cratchet Robert) (accounting scrivener)))
+ (assert! (salary (Cratchet Robert) 18000))
+ (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
+ (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
+ (assert! (job (Aull DeWitt) (administration secretary)))
+ (assert! (salary (Aull DeWitt) 25000))
+ (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
+ (assert! (can-do-job (computer wizard) (computer programmer)))
+ (assert! (can-do-job (computer wizard) (computer technician)))
+ (assert! (can-do-job (computer programmer)
+ (computer programmer trainee)))
+ (assert! (can-do-job (administration secretary)
+ (administration big wheel)))))
+
+(eval-query
+ '(assert! (rule (same ?x ?x))))
+
+(newline)
+(test-query
+ '(supervisor ?employee (Bitdiddle Ben))
+ '((supervisor (tweakit lem e) (bitdiddle ben))
+ (supervisor (fect cy d) (bitdiddle ben))
+ (supervisor (hacker alyssa p) (bitdiddle ben))))
+(test-query
+ '(job ?x (accounting . ?title))
+ '((job (cratchet robert) (accounting scrivener))
+ (job (scrooge eben) (accounting chief accountant))))
+(test-query
+ '(address ?person (Slumerville . ?rest))
+ '((address (aull dewitt) (slumerville (onion square) 5))
+ (address (reasoner louis) (slumerville (pine tree road) 80))
+ (address (bitdiddle ben) (slumerville (ridge road) 10))))
+(test-query
+ '(and (supervisor ?x (Bitdiddle Ben))
+ (address ?x ?address))
+ '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
+ (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
+ (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
+(test-query
+ '(and (salary (Bitdiddle Ben) ?ben-salary)
+ (salary ?x ?x-salary)
+ (lisp-value < ?x-salary ?ben-salary))
+ '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
+ (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
+(test-query
+ '(and (supervisor ?employee ?supervisor)
+ (job ?supervisor ?job)
+ (not (job ?supervisor (computer . ?title))))
+ '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
+ (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
+ (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
+
+(eval-query
+ '(assert! (rule (can-replace? ?p1 ?p2)
+ (and (or (and (job ?p1 ?job)
+ (job ?p2 ?job))
+ (and (job ?p1 ?j1)
+ (job ?p2 ?j2)
+ (can-do-job ?j1 ?j2)))
+ (not (same ?p1 ?p2))))))
+(test-query
+ '(can-replace? ?x (Fect Cy D))
+ '((can-replace? (bitdiddle ben) (fect cy d))
+ (can-replace? (hacker alyssa p) (fect cy d))))
+(test-query
+ '(and (salary ?low ?low-salary)
+ (salary ?high ?high-salary)
+ (can-replace? ?low ?high)
+ (lisp-value < ?low-salary ?high-salary))
+ '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
+ (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
+(eval-query
+ '(assert! (rule (big-shot ?bigshot)
+ (and (job ?bigshot (?dept . ?job-title))
+ (or (not (supervisor ?bigshot ?boss))
+ (and (supervisor ?bigshot ?boss)
+ (not (job ?boss (?dept . ?boss-title)))))))))
+(test-query
+ '(big-shot ?x)
+ '((big-shot (warbucks oliver))
+ (big-shot (scrooge eben))
+ (big-shot (bitdiddle ben))))
+(eval-queries
+ '((assert! (meeting accounting (Monday 9am)))
+ (assert! (meeting administration (Monday 10am)))
+ (assert! (meeting computer (Wednesday 3pm)))
+ (assert! (meeting administration (Friday 1pm)))
+ (assert! (meeting whole-company (Wednesday 4pm)))))
+(test-query '(meeting ?div (Friday ?time))
+ '((meeting administration (friday 1pm))))
+(eval-query
+ '(assert! (rule (meeting-time ?person ?day-and-time)
+ (or (and (job ?person (?dept . ?title))
+ (meeting ?dept ?day-and-time))
+ (meeting whole-company ?day-and-time)))))
+
+(test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
+ '((meeting-time (hacker alyssa p) (wednesday 3pm))
+(meeting-time (hacker alyssa p) (wednesday 4pm))))
+
+(define (name<? name1 name2)
+ (let ((str1 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name1))
+ (str2 (fold-left
+ (lambda (str sym)
+ (string-append str (symbol->string sym)))
+ ""
+ name2)))
+ (string<? str1 str2)))
+
+(eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
+ (and (address ?person-1 (?town . ?rest-1))
+ (address ?person-2 (?town . ?rest-2))
+ (not (same ?person-1 ?person-2))
+ (lisp-value name<? ?person-1 ?person-2)))))
+
+(test-query '(lives-near ?person-1 ?person-2)
+ '((lives-near (aull dewitt) (reasoner louis))
+ (lives-near (aull dewitt) (bitdiddle ben))
+ (lives-near (fect cy d) (hacker alyssa p))
+ (lives-near (bitdiddle ben) (reasoner louis))))
+(eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
+(eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
+ (?x next-to ?y in ?z))))
+(test-query '(?x next-to ?y in (1 (2 3) 4))
+ '(((2 3) next-to 4 in (1 (2 3) 4))
+ (1 next-to (2 3) in (1 (2 3) 4))))
+(test-query '(?x next-to 1 in (2 1 3 1))
+ '((3 next-to 1 in (2 1 3 1))
+ (2 next-to 1 in (2 1 3 1))))
+(eval-queries
+ '((assert! (rule (last-pair (?x) (?x))))
+ (assert! (rule (last-pair (?x . ?y) (?z))
+ (last-pair ?y (?z))))))
+(test-query '(last-pair (3) ?x)
+ '((last-pair (3) (3))))
+(test-query '(last-pair (1 2 3))
+ '((last-pair (1 2 3) (3))))
+(test-query '(last-pair (2 ?x) (3))
+ '((last-pair (2 3) (3))))
+(eval-queries
+ '((assert! (son Adam Cain))
+ (assert! (son Cain Enoch))
+ (assert! (son Enoch Irad))
+ (assert! (son Irad Mehujael))
+ (assert! (son Mehujael Methushael))
+ (assert! (son Methushael Lamech))
+ (assert! (wife Lamech Ada))
+ (assert! (son Ada Jabal))
+ (assert! (son Ada Jubal))))
+(eval-queries
+ '((assert! (rule (grandson ?g ?s)
+ (and (son ?g ?f)
+ (son ?f ?s))))
+ (assert! (rule (son ?f ?s)
+ (and (wife ?f ?m)
+ (son ?m ?s))))))
+(test-query
+ '(grandson Cain ?grandson)
+ '((grandson cain irad)))
+(test-query
+ '(son Lamech ?son)
+ '((son lamech jubal)
+ (son lamech jabal)))
+(test-query
+ '(grandson Methushael ?grandson)
+ '((grandson methushael jubal)
+ (grandson methushael jabal)))
+
+(eval-queries
+ '((assert! (rule (append-to-form () ?y ?y)))
+ (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
+ (append-to-form ?v ?y ?z)))
+ (assert! (rule (reverse () ())))
+ (assert! (rule (reverse (?x . ?y) ?rev)
+ (and (reverse ?y ?rev-y)
+ (append-to-form ?rev-y (?x) ?rev))))))
+(test-query '(reverse (1 2 3) ?x)
+ '((reverse (1 2 3) (3 2 1))))
+
+ ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
+
+(eval-queries
+ '((assert! (rule (ends-in-grandson? (grandson))))
+ (assert! (rule (ends-in-grandson? (?x . ?y))
+ (ends-in-grandson? ?y)))))
+;; (test-query '(ends-in-grandson? (father)))
+;; (test-query '(ends-in-grandson? (son mother father)))
+;; (test-query '(ends-in-grandson? (grandson)))
+;; (test-query '(ends-in-grandson? (father son grandson mother)))
+;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
+
+(eval-queries
+ '((assert! (rule ((great . ?rel) ?x ?y)
+ (and (ends-in-grandson? ?rel)
+ (son ?x ?z)
+ (?rel ?z ?y))))
+ (assert! (rule ((grandson) ?x ?y)
+ (grandson ?x ?y)))))
+
+;; ((great great great grandson) Adam ?somebody)
+;; ((great . ?rel) ?x ?y)
+
+;; ?rel -> (great great grandson)
+;; ?x -> Adam
+;; ?somebody -> ?y
+
+;; (and (ends-in-grandson? ?rel)
+;; (son ?x ?z)
+;; (?rel ?z ?y))
+;; (and (son Adam ?z)
+;; ((great great grandson) ?z ?y))
+
+;; (son Adam ?z)
+;; (son Adam Cain)
+;; ?z -> Cain
+
+;; ((great great grandson) Cain ?y)
+;; ((great . ?rel1) ?x1 ?y1)
+;; ?rel1 -> (great grandson)
+;; ?x1 -> Cain
+;; ?y -> ?y1
+;; (and (son Cain ?z1)
+;; ((great grandson) ?z1 ?y1))
+;; ?z1 -> Enoch
+;; ((great grandson) Enoch ?y1)
+;; ((great . ?rel2) ?x2 ?y2)
+;; ?rel2 -> (grandson)
+;; ?x2 -> Enoch
+;; ?y1 -> ?y2
+;; (and (son Enoch ?z2)
+;; ((grandson) ?z2 ?y2))
+;; ?z2 -> Irad
+;; ((grandson) Irad ?y2)
+
+;; (assert! (son Adam Cain))
+;; (assert! (son Cain Enoch))
+;; (assert! (son Enoch Irad))
+;; (assert! (son Irad Mehujael))
+;; (assert! (son Mehujael Methushael))
+;; (assert! (son Methushael Lamech))
+;; (assert! (wife Lamech Ada))
+;; (assert! (son Ada Jabal))
+;; (assert! (son Ada Jubal))
+
+(test-query '((great grandson) ?great-grandfather Irad)
+ '(((great grandson) Adam Irad)))
+(test-query '((great great great great great grandson) Adam ?x)
+ '(((great great great great great grandson) Adam Jubal)
+ ((great great great great great grandson) Adam Jabal)))
+
+(test-query '((great grandson) ?g ?ggs)
+ '(((great grandson) mehujael jubal)
+ ((great grandson) irad lamech)
+ ((great grandson) mehujael jabal)
+ ((great grandson) enoch methushael)
+ ((great grandson) cain mehujael)
+ ((great grandson) adam irad)))
+
+;; (test-query '(?relationship Adam Irad))
+;; this goes into an infinite loop
+(define (simple-stream-flatmap proc s)
+ (simple-flatten (stream-map proc s)))
+
+(define (simple-flatten stream)
+ (stream-map stream-car
+ (stream-filter (lambda (x) (not (stream-null? x))) stream)))
+
+
+ ;; Exercise 4.75. Implement for the query language a new special form called unique. Unique should succeed if there is precisely one item in the data base satisfying a specified query. For example,
+
+(define (uniquely-asserted operands frame-stream)
+ (stream-flatmap
+ (lambda (frame)
+ (let ((results-stream
+ (qeval (unique-query operands)
+ (singleton-stream frame))))
+ (if (singleton-stream? results-stream)
+ results-stream
+ the-empty-stream)))
+ frame-stream))
+(define (unique-query operands)
+ (car operands))
+(define (singleton-stream? s)
+ (and (not (stream-null? s))
+ (stream-null? (stream-cdr s))))
+(put 'unique 'qeval uniquely-asserted)
+
+(test-query '(unique (job ?x (computer wizard)))
+ '((unique (job (Bitdiddle Ben) (computer wizard)))))
+(test-query '(unique (job ?x (computer programmer)))
+ '())
+(test-query '(and (job ?x ?j)
+ (unique (job ?anyone ?j)))
+ '((and (job (aull dewitt) (administration secretary)) (unique (job (aull dewitt) (administration secretary))))
+ (and (job (cratchet robert) (accounting scrivener)) (unique (job (cratchet robert) (accounting scrivener))))
+ (and (job (scrooge eben) (accounting chief accountant)) (unique (job (scrooge eben) (accounting chief accountant))))
+ (and (job (warbucks oliver) (administration big wheel)) (unique (job (warbucks oliver) (administration big wheel))))
+ (and (job (reasoner louis) (computer programmer trainee)) (unique (job (reasoner louis) (computer programmer trainee))))
+ (and (job (tweakit lem e) (computer technician)) (unique (job (tweakit lem e) (computer technician))))
+ (and (job (bitdiddle ben) (computer wizard)) (unique (job (bitdiddle ben) (computer wizard))))))
+(test-query '(and (supervisor ?sub ?sup)
+ (unique (supervisor ?anyone ?sup)))
+ '((and (supervisor (cratchet robert) (scrooge eben)) (unique (supervisor (cratchet robert) (scrooge eben))))
+ (and (supervisor (reasoner louis) (hacker alyssa p)) (unique (supervisor (reasoner louis) (hacker alyssa p))))))
+
+;; Exercise 4.76. Our implementation of and as a series combination of queries (figure 4.5) is elegant, but it is inefficient because in processing the second query of the and we must scan the data base for each frame produced by the first query. If the data base has N elements, and a typical query produces a number of output frames proportional to N (say N/k), then scanning the data base for each frame produced by the first query will require N2/k calls to the pattern matcher. Another approach would be to process the two clauses of the and separately, then look for all pairs of output frames that are compatible. If each query produces N/k output frames, then this means that we must perform N2/k2 compatibility checks -- a factor of k fewer than the number of matches required in our current method.
+
+;; Devise an implementation of and that uses this strategy. You must implement a procedure that takes two frames as inputs, checks whether the bindings in the frames are compatible, and, if so, produces a frame that merges the two sets of bindings. This operation is similar to unification.
+
+;; returns merged frame or 'failed
+(define (merge-frame frame1 frame2)
+ (if (null? frame1)
+ frame2
+ (let* ((binding (first-binding frame1))
+ (var (binding-variable binding))
+ (val (binding-value binding))
+ (merged-result (extend-if-possible var val frame2)))
+ (if (eq? merged-result 'failed)
+ 'failed
+ (merge-frame (rest-bindings frame1) frame2)))))
+
+;; returns stream of frames that can be merged
+(define (merge-streams s1 s2)
+ (stream-flatmap
+ (lambda (f1)
+ (stream-flatmap
+ (lambda (f2)
+ (let ((merged-frame (merge-frame f1 f2)))
+ (if (eq? merged-frame 'failed)
+ the-empty-stream
+ (singleton-stream merged-frame))))
+ s2))
+ s1))
+(define (conjoin conjuncts frame-stream)
+ (if (empty-conjunction? conjuncts)
+ frame-stream
+ (merge-streams
+ (qeval (first-conjunct conjuncts) frame-stream)
+ (conjoin (rest-conjuncts conjuncts) frame-stream))))
+
+(define (first-binding frame)
+ (car frame))
+(define (rest-bindings frame)
+ (cdr frame))
+(define (make-binding variable value)
+ (cons variable value))
+(define (binding-variable binding)
+ (car binding))
+(define (binding-value binding)
+ (cdr binding))
+(define (binding-in-frame variable frame)
+ (assoc variable frame))
+(define (extend variable value frame)
+ (cons (make-binding variable value) frame))
blob - /dev/null
blob + f14141202c2e26359576b5f6c075d0d96a35ddcc (mode 644)
--- /dev/null
+++ ex4-8.scm
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.8. ``Named let'' is a variant of let that has the form
+
+;; (let <var> <bindings> <body>)
+
+;; The <bindings> and <body> are just as in ordinary let, except that <var> is bound within <body> to a procedure whose body is <body> and whose parameters are the variables in the <bindings>. Thus, one can repeatedly execute the <body> by invoking the procedure named <var>. For example, the iterative Fibonacci procedure (section 1.2.2) can be rewritten using named let as follows:
+
+;; (let fib-iter ((a 1)
+;; (b 0)
+;; (count n))
+;; (if (= count 0)
+;; b
+;; (fib-iter (+ a b) a (- count 1))))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+
blob - /dev/null
blob + 79bfabad52da9a7cb87a410e518bc345983eef0d (mode 644)
--- /dev/null
+++ ex4-8.scm~
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (tagged-list? exp 'let))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+
+;; Exercise 4.8. ``Named let'' is a variant of let that has the form
+
+;; (let <var> <bindings> <body>)
+
+;; The <bindings> and <body> are just as in ordinary let, except that <var> is bound within <body> to a procedure whose body is <body> and whose parameters are the variables in the <bindings>. Thus, one can repeatedly execute the <body> by invoking the procedure named <var>. For example, the iterative Fibonacci procedure (section 1.2.2) can be rewritten using named let as follows:
+
+(define (named-let? exp)
+ (and (tagged-list exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cadddr exp))
+
+
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 10) 55)
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8))
+(test-eval
+ '(begin
+ (let loop (count 0)
+ (if (= 100 count)
+ 'done
+ (begin (set! count (+ count 1))
+ (loop))))
+ (loop)))
+
+
+(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1)))))
+
+
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
blob - /dev/null
blob + 406f448f51001f2cb20d1bb598f8457f15c5b911 (mode 644)
--- /dev/null
+++ ex4-9-2.scm
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+(define (make-named-let name vars vals body)
+ (cons 'let
+ (cons name
+ (cons (map list vars vals)
+ body))))
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+;; do loop
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (make-named-let
+ 'do-iter
+ (do-vars exp)
+ (do-inits exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.9. Many languages support a variety of iteration constructs, such as do, for, while, and until. In Scheme, iterative processes can be expressed in terms of ordinary procedure calls, so special iteration constructs provide no essential gain in computational power. On the other hand, such constructs are often convenient. Design some iteration constructs, give examples of their use, and show how to implement them as derived expressions.
+
+;; Implemented according to this spec:
+;; http://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Iteration.html
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+;; do-loop
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
blob - /dev/null
blob + 00d00103dace614b84ec6e0adb7584a5d34feedc (mode 644)
--- /dev/null
+++ ex4-9-2.scm~
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.9. Many languages support a variety of iteration constructs, such as do, for, while, and until. In Scheme, iterative processes can be expressed in terms of ordinary procedure calls, so special iteration constructs provide no essential gain in computational power. On the other hand, such constructs are often convenient. Design some iteration constructs, give examples of their use, and show how to implement them as derived expressions.
+
+;; Implemented according to this spec:
+;; http://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Iteration.html
+
+
+;; (do ((vec (make-vector 5))
+;; (i 0 (+ i 1)))
+;; ((= i 5) vec)
+;; (vector-set! vec i i)) => #(0 1 2 3 4)
+
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (sequence->exp
+ (list
+ (make-definition
+ 'do-iter
+ (make-lambda
+ (do-vars exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+ (make-application 'do-iter (do-inits exp)))))
+
+
+;; (define do-name
+;; (lambda (x y)
+;; (if (null? x)
+;; (begin y x (car y)) ;; if there are no expressions, then (null? x) would be returned
+;; (begin (display 'command)
+;; (display 'another)
+;; (do-name (cdr x) (cddr y))) ;; if the step is omitted, it is simply x y
+;; (do-name '(1 2 3 4)
+;; '(1 2 3 4 5 6 7 8))
+
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+
blob - /dev/null
blob + 00d00103dace614b84ec6e0adb7584a5d34feedc (mode 644)
--- /dev/null
+++ ex4-9.scm
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.9. Many languages support a variety of iteration constructs, such as do, for, while, and until. In Scheme, iterative processes can be expressed in terms of ordinary procedure calls, so special iteration constructs provide no essential gain in computational power. On the other hand, such constructs are often convenient. Design some iteration constructs, give examples of their use, and show how to implement them as derived expressions.
+
+;; Implemented according to this spec:
+;; http://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Iteration.html
+
+
+;; (do ((vec (make-vector 5))
+;; (i 0 (+ i 1)))
+;; ((= i 5) vec)
+;; (vector-set! vec i i)) => #(0 1 2 3 4)
+
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (sequence->exp
+ (list
+ (make-definition
+ 'do-iter
+ (make-lambda
+ (do-vars exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+ (make-application 'do-iter (do-inits exp)))))
+
+
+;; (define do-name
+;; (lambda (x y)
+;; (if (null? x)
+;; (begin y x (car y)) ;; if there are no expressions, then (null? x) would be returned
+;; (begin (display 'command)
+;; (display 'another)
+;; (do-name (cdr x) (cddr y))) ;; if the step is omitted, it is simply x y
+;; (do-name '(1 2 3 4)
+;; '(1 2 3 4 5 6 7 8))
+
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+
+(test-eval
+ '(do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+
blob - /dev/null
blob + d64df722bf0c1db8e8e3ef4f6e3ce5e98009904b (mode 644)
--- /dev/null
+++ ex4-9.scm~
+(define (eval exp env)
+ (cond ((self-evaluating? exp) exp)
+ ((variable? exp) (lookup-variable-value exp env))
+ ((quoted? exp) (text-of-quotation exp))
+ ((assignment? exp) (eval-assignment exp env))
+ ((definition? exp) (eval-definition exp env))
+ ((if? exp) (eval-if exp env))
+ ((and? exp) (eval-and exp env))
+ ((or? exp) (eval-or exp env))
+ ((lambda? exp)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence (begin-actions exp) env))
+ ((cond? exp) (eval (cond->if exp) env))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((named-let? exp) (eval (named-let->combination exp) env))
+ ((do? exp) (eval (do->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+(define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure procedure arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure))))
+ (else
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+;; self-evaluating/variable/quoted
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+;; assignment/definition
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+(define (make-definition var val)
+ `(define ,var ,val))
+
+
+;; if/and/or
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (and? exp)
+ (tagged-list? exp 'and))
+(define (and-clauses exp)
+ (cdr exp))
+(define (or? exp)
+ (tagged-list? exp 'or))
+(define (or-clauses exp)
+ (cdr exp))
+(define (eval-and exp env)
+ (define (eval-clauses clauses)
+ (cond ((null? clauses) true)
+ ((null? (cdr clauses)) (eval (car clauses) env))
+ (else (and (eval (car clauses) env)
+ (eval-clauses (cdr clauses))))))
+ (eval-clauses (and-clauses exp)))
+(define (eval-or exp env)
+ (define (eval-clauses clauses)
+ (if (null? clauses)
+ false
+ (or (eval (car clauses) env)
+ (eval-clauses (cdr clauses)))))
+ (eval-clauses (or-clauses exp)))
+
+
+;; lambda/let/let*
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map (lambda (var val)
+ (list var val))
+ vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (named-let? exp)
+ (and (tagged-list? exp 'let)
+ (symbol? (cadr exp))))
+(define (named-let-name exp)
+ (cadr exp))
+(define (named-let-vars exp)
+ (map car (caddr exp)))
+(define (named-let-vals exp)
+ (map cadr (caddr exp)))
+(define (named-let-body exp)
+ (cdddr exp))
+(define (named-let->combination exp)
+ (sequence->exp
+ (list (make-definition (named-let-name exp)
+ (make-lambda (named-let-vars exp)
+ (named-let-body exp)))
+ (make-application (named-let-name exp)
+ (named-let-vals exp)))))
+
+
+(define (make-application op args)
+ (cons op args))
+
+(define (let*? exp)
+ (tagged-list? exp 'let*))
+(define let*-vars let-vars)
+(define let*-vals let-vals)
+(define let*-body let-body)
+(define (let*->nested-lets exp)
+ (define (expand-lets vars vals)
+ (if (null? (cdr vars))
+ (make-let (list (car vars))
+ (list (car vals))
+ (let*-body exp))
+ (make-let (list (car vars))
+ (list (car vals))
+ (list (expand-lets (cdr vars) (cdr vals))))))
+ (let ((vars (let*-vars exp))
+ (vals (let*-vals exp)))
+ (if (null? vars)
+ (sequence->exp (let*-body exp))
+ (expand-lets vars vals))))
+
+
+;; begin/sequence
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+;; application
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond-extended-clause? clause)
+ (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
+(define (cond-extended-proc clause)
+ (caddr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (if (cond-extended-clause? first)
+ (make-if (cond-predicate first)
+ (make-application
+ (cond-extended-proc first)
+ (list (cond-predicate first)))
+ (expand-clauses rest))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; procedure
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;; primitives
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; driver-loop
+(define input-prompt ";;; M-Eval input:")
+(define output-prompt ";;; M-Eval value:")
+(define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+
+;; auxiliary
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+(define (geval exp) ;; eval globally
+ (eval exp the-global-environment))
+(define (test-eval exp expected)
+ (test-case (geval exp) expected))
+
+;; Exercise 4.9. Many languages support a variety of iteration constructs, such as do, for, while, and until. In Scheme, iterative processes can be expressed in terms of ordinary procedure calls, so special iteration constructs provide no essential gain in computational power. On the other hand, such constructs are often convenient. Design some iteration constructs, give examples of their use, and show how to implement them as derived expressions.
+
+;; Implemented according to this spec:
+;; http://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Iteration.html
+
+
+;; (do ((vec (make-vector 5))
+;; (i 0 (+ i 1)))
+;; ((= i 5) vec)
+;; (vector-set! vec i i)) => #(0 1 2 3 4)
+
+(define (do? exp)
+ (tagged-list? exp 'do))
+(define (do-vars exp)
+ (map car (cadr exp)))
+(define (do-inits exp)
+ (map cadr (cadr exp)))
+(define (do-steps exp)
+ (map (lambda (var-init-step)
+ (if (null? (cddr var-init-step))
+ (car var-init-step)
+ (caddr var-init-step)))
+ (cadr exp)))
+(define (do-test exp)
+ (caaddr exp))
+(define (do-expressions exp)
+ (if (null? (cdaddr exp))
+ (caddr exp)
+ (cdaddr exp)))
+(define (do-commands exp)
+ (cdddr exp))
+(define (do->combination exp)
+ (sequence->exp
+ (list
+ (make-definition
+ 'do-iter
+ (make-lambda
+ (do-vars exp)
+ (list
+ (make-if
+ (do-test exp)
+ (sequence->exp (do-expressions exp))
+ (sequence->exp
+ (append (do-commands exp)
+ (list (make-application
+ 'do-iter
+ (do-steps exp)))))))))
+ (make-application 'do-iter (do-inits exp)))))
+
+
+;; (define do-name
+;; (lambda (x y)
+;; (if (null? x)
+;; (begin y x (car y)) ;; if there are no expressions, then (null? x) would be returned
+;; (begin (display 'command)
+;; (display 'another)
+;; (do-name (cdr x) (cddr y))) ;; if the step is omitted, it is simply x y
+;; (do-name '(1 2 3 4)
+;; '(1 2 3 4 5 6 7 8))
+
+(test-eval
+ '(do ()
+ (true))
+ true)
+(test-eval
+ '(do ()
+ (true 5))
+ 5)
+(test-eval
+ '(let ((y 0))
+ (do ()
+ ((= y 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ (do ((y '(1 2 3 4)))
+ ((null? y))
+ (set! y (cdr y)))
+ true)
+(test-eval
+ '(let ((y 0))
+ (do ((x 0 (+ x 1)))
+ ((= x 5) y)
+ (set! y (+ y 1))))
+ 5)
+(test-eval
+ '(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))
+ 25)
+(test-eval
+ '(let ((z '()))
+ (do ((x '(1 2 3 4) (cdr x))
+ (y '(1 2 3 4 5 6 7 8) (cddr y)))
+ ((null? x) y x z)
+ (set! z (cons (car x) z))))
+ '(4 3 2 1))
+(begin
+ (define do-iter
+ (lambda (x)
+ (if (= x 5)
+ y
+ (begin
+ (set! y (+ y 1))
+ (do-iter (+ x 1))))))
+ (do-iter 0))
+somehow we are evaluating true and not 'true
+
+we could actually rewrite this as a named-let
+(let do-iter ((x 0))
+ (if (= x 5)
+ y
+ (begin
+ (set! y (+ y 1))
+ (do-iter (+ x 1)))))
+
+
+;; test-suite
+
+;; procedure definitions
+
+(geval
+ '(define (assoc key records)
+ (cond ((null? records) false)
+ ((equal? key (caar records)) (car records))
+ (else (assoc key (cdr records))))))
+
+(geval
+ '(define (map proc list)
+ (if (null? list)
+ '()
+ (cons (proc (car list))
+ (map proc (cdr list))))))
+
+(geval
+ '(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence))))))
+
+;; all special forms
+(test-eval '(begin 5 6) 6)
+(test-eval '10 10)
+(geval '(define x 3))
+(test-eval 'x 3)
+(test-eval '(set! x -25) 'ok)
+(test-eval 'x -25)
+(geval '(define z (lambda (x y) (+ x (* x y)))))
+(test-eval '(z 3 4) 15)
+(test-eval '(cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed))
+ 'x=-25)
+(test-eval '(if true false true) false)
+(test-eval
+ '(let ((x 4) (y 7))
+ (+ x y (* x y)))
+ (+ 4 7 (* 4 7)))
+
+
+;; and/or
+(geval '(define x (+ 3 8)))
+(test-eval '(and 0 true x) 11)
+(test-eval '(and 0 true x false) false)
+(test-eval '(and 0 true x (set! x -2) false) false)
+(test-eval 'x -2)
+(test-eval '(and 0 true x false (set! x -5)) false)
+(test-eval 'x -2)
+(test-eval '(or false (set! x 25)) 'ok)
+(test-eval 'x 25)
+(test-eval '(or (set! x 2) (set! x 4)) 'ok)
+(test-eval 'x 2)
+(test-eval '(or false (set! x 25) true false) 'ok)
+(test-eval 'x 25)
+(test-eval '(or ((lambda (x) x) 5)) 5)
+(test-eval '(or (begin (set! x (+ x 1)) x)) 26)
+
+
+;; cond
+
+(test-eval
+ '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
+ (else false))
+ 2)
+
+(test-eval
+ '(cond ((= 3 4) 'not-true)
+ ((= (* 2 4) 3) 'also-false)
+ ((map (lambda (x)
+ (* x (+ x 1)))
+ '(2 4 1 9))
+ =>
+ (lambda (x)
+ (accumulate + 0 x)))
+ (else 'never-reach))
+ 118)
+;; '(6 20 2 90)
+
+
+;; procedure definition and application
+(geval
+ '(define (factorial n)
+ (if (= n 0)
+ 1
+ (* n (factorial (- n 1))))))
+(test-eval '(factorial 5) 120)
+
+;; map
+
+(test-eval
+ '(map (lambda (x)
+ (* x (+ x 1)))
+ '(2 1 4 2 8 3))
+ '(6 2 20 6 72 12))
+;; accumulate
+
+(test-eval
+ '(accumulate + 0 '(1 2 3 4 5))
+ 15)
+
+;; make-let
+(test-eval
+ (make-let '(x y) '(3 5) '((+ x y)))
+ 8)
+(test-eval
+ '(let ()
+ 5)
+ 5)
+(test-eval
+ '(let ((x 3))
+ x)
+ 3)
+(test-eval
+ '(let ((x 3)
+ (y 5))
+ (+ x y))
+ 8)
+(test-eval
+ '(let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 4 3) 3 2))
+(test-eval
+ '(let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z))
+ (+ 6 5 9))
+
+
+;; let*
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 2))
+ (z (+ x y 5)))
+ (* x z))
+ 39)
+
+(test-eval
+ '(let* ()
+ 5)
+ 5)
+(test-eval
+ '(let* ((x 3))
+ (let* ((y 5))
+ (+ x y)))
+ 8)
+
+(test-eval
+ '(let* ((x 3)
+ (y (+ x 1)))
+ (+ (let* ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y))
+ (+ (* 6 6) 3 4))
+(test-eval
+ '(let* ((x 6)
+ (y (let* ((x 2)
+ (a (let* ((x (* 3 x)))
+ (+ x 2))))
+ (+ x a)))
+ (z (+ x y)))
+ (+ x y z))
+ 32)
+
+;; named-let
+
+(test-eval
+ '(let eight ()
+ 5
+ 7
+ 8)
+ 8)
+(test-eval
+ '(let loop ((count 0))
+ (if (= 100 count)
+ count
+ (loop (+ count 1))))
+ 100)
+(geval
+ '(define (prime? x)
+ (let prime-iter ((i 2))
+ (cond ((> (* i i) x) true)
+ ((= (remainder x i) 0) false)
+ (else (prime-iter (+ i 1)))))))
+(test-eval
+ '(let primes ((x 2)
+ (n 20))
+ (cond ((= n 0) '())
+ ((prime? x)
+ (cons x
+ (primes (+ x 1) (- n 1))))
+ (else (primes (+ x 1) n))))
+ '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
+
+(geval
+ '(define (fib n)
+ (let fib-iter ((a 1)
+ (b 0)
+ (count n))
+ (if (= count 0)
+ b
+ (fib-iter (+ a b) a (- count 1))))))
+(test-eval '(fib 19) 4181)
+
+
blob - /dev/null
blob + 8bd1c1449255eac74a13a4ad1f35525fde9f9cd5 (mode 644)
--- /dev/null
+++ ex5-1.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (receive insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels))
+ (receive (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+
+;; Exercise 5.1. Design a register machine to compute factorials using the iterative algorithm specified by the following procedure. Draw data-path and controller diagrams for this machine.
+
+(define (factorial n)
+ (define (iter product counter)
+ (if (> counter n)
+ product
+ (iter (* counter product)
+ (+ counter 1))))
+ (iter 1 1))
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+
blob - /dev/null
blob + 1e983f774e675f9d2ec73477c450856b9bf9435d (mode 644)
--- /dev/null
+++ ex5-1.scm~
+;; repeat 2-3 times
+
+
+(define (make-machine reg-names ops controller)
+ (let ((machine (make-new-machine)))
+ (for-each
+ (lambda (name)
+ ((machine 'allocate-register) name))
+ reg-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller machine))
+ machine))
+
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (val) (set! contents val)))
+ (else (error "Unknown request -- REGISTER"
+ message))))
+ dispatch))
+
+(define (set-contents! reg val)
+ ((reg 'set) val))
+(define (get-contents reg)
+ (reg 'get))
+
+(define (make-stack)
+ (let ((s '()))
+ (define (push x)
+ (set! s (cons x s)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ top)))
+ (define (initialize)
+ (set! s '())
+ 'done)
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ (else (error "Unknown request -- STACK"
+ message))))
+ dispatch))
+(define (push stack value)
+ ((stack 'push) value))
+(define (pop stack)
+ (stack 'pop))
+(define (make-new-machine)
+ (let* ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '())
+ (register-table
+ `((pc ,pc)
+ (flag ,flag)))
+ (the-ops
+ (list (list 'initialize-stack
+ (lambda ()
+ (stack 'initialize))))))
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register -- LOOKUP" name))))
+ (define (allocate-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table))))
+ 'done)
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'lookup-register) lookup-register)
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'stack) stack)
+ ((eq? message 'install-operations)
+ (lambda (ops)
+ (set! the-ops (append the-ops ops))))
+ ((eq? message 'operations) the-ops)
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq)
+ (set! the-instruction-sequence seq)))))
+ dispatch))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+
+(define (get-register machine name)
+ ((machine 'lookup-register) name))
+(define (get-register-contents machine name)
+ (get-contents (get-register machine name)))
+(define (set-register-contents! machine name value)
+ (set-contents! (get-register machine name) value))
+(define (start machine)
+ (machine 'start))
+
+(define (assemble controller machine)
+ (extract-labels
+ controller
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+
+;; (define (extract-labels text receive)
+;; (if (null? text)
+;; (cons '() '())
+;; (let* ((result (extract-labels (cdr text)))
+;; (insts (car result))
+;; (labels (cdr result))
+;; (next-inst (car text)))
+;; (if (symbol? next-inst)
+;; (cons insts
+;; (cons (make-label-entry next-inst insts)
+;; labels))
+;; (cons (cons (make-instruction next-inst)
+;; insts)
+;; labels)))))
+;; (define (assemble controller machine)
+;; (let* ((result (extract-labels controller))
+;; (insts (car result))
+;; (labels (cdr result)))
+;; (update-insts! insts labels machine)
+;; insts))
+
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels
+ (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst insts)
+ labels))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (make-execution-procedure text labels machine
+ pc flags stack ops)
+ ...)
+;; unfinished!
blob - /dev/null
blob + 7632deb95048dcefe00affad9d37ebed1a25d37d (mode 644)
--- /dev/null
+++ ex5-10.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
blob - /dev/null
blob + ef156f22f8f55b75302b7db56828e9a446dc0a1a (mode 644)
--- /dev/null
+++ ex5-10.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (if (label-exp? e)
+ (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ exp)
+ (make-primitive-exp e machine labels)))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+ ;; Exercise 5.9. The treatment of machine operations above permits them to operate on labels as well as on constants and the contents of registers. Modify the expression-processing procedures to enforce the condition that operations can be used only with registers and constants.
+
+(define op-label-machine
+ (make-machine
+ '(x)
+ `((+ ,+))
+ '((assign x (op +) (label a) (label b)))))
blob - /dev/null
blob + 900222b36c35004711eec27d076be5b7a11ba6ba (mode 644)
--- /dev/null
+++ ex5-12-b.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+;; Exercise 5.11. When we introduced save and restore in section 5.1.4, we didn't specify what would happen if you tried to restore a register that was not the last one saved, as in the sequence
+
+;; (save y)
+;; (save x)
+;; (restore y)
+
+;; There are several reasonable possibilities for the meaning of restore:
+
+;; a. (restore y) puts into y the last value saved on the stack, regardless of what register that value came from. This is the way our simulator behaves. Show how to take advantage of this behavior to eliminate one instruction from the Fibonacci machine of section 5.1.4 (figure 5.12).
+
+;; (assign n (reg val))
+;; (restore val)
+
+;; can now be shortened to
+
+;; (restore n)
+
+;; b. (restore y) puts into y the last value saved on the stack, but only if that value was saved from y; otherwise, it signals an error. Modify the simulator to behave this way. You will have to change save to put the register name on the stack along with the value.
+
+;; (define mismatch-machine
+;; (make-machine
+;; '(x y)
+;; '()
+;; '((assign x (const 5))
+;; (assign y (const 4))
+;; (save y)
+;; (save x)
+;; (restore y))))
+;; (start mismatch-machine)
+
+
+;; c. (restore y) puts into y the last value saved from y regardless of what other registers were saved after y and not restored. Modify the simulator to behave this way. You will have to associate a separate stack with each register. You should make the initialize-stack operation initialize all the register stacks.
blob - /dev/null
blob + eb444fbd2e289899c0206a6e490bf84843c48a53 (mode 644)
--- /dev/null
+++ ex5-12-b.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+;; Exercise 5.11. When we introduced save and restore in section 5.1.4, we didn't specify what would happen if you tried to restore a register that was not the last one saved, as in the sequence
+
+;; (save y)
+;; (save x)
+;; (restore y)
+
+;; There are several reasonable possibilities for the meaning of restore:
+
+;; a. (restore y) puts into y the last value saved on the stack, regardless of what register that value came from. This is the way our simulator behaves. Show how to take advantage of this behavior to eliminate one instruction from the Fibonacci machine of section 5.1.4 (figure 5.12).
+
+;; (assign n (reg val))
+;; (restore val)
+
+;; can now be shortened to
+
+;; (restore n)
+
+;; b. (restore y) puts into y the last value saved on the stack, but only if that value was saved from y; otherwise, it signals an error. Modify the simulator to behave this way. You will have to change save to put the register name on the stack along with the value.
+
+
+
+;; c. (restore y) puts into y the last value saved from y regardless of what other registers were saved after y and not restored. Modify the simulator to behave this way. You will have to associate a separate stack with each register. You should make the initialize-stack operation initialize all the register stacks.
blob - /dev/null
blob + 256850af5baf972dbea0619570c277f5e7267ab5 (mode 644)
--- /dev/null
+++ ex5-12-c.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+;; (define (make-stack)
+;; (let ((s '())
+;; (number-pushes 0)
+;; (max-depth 0)
+;; (current-depth 0))
+;; (define (push x)
+;; (set! s (cons x s))
+;; (set! number-pushes (+ 1 number-pushes))
+;; (set! current-depth (+ 1 current-depth))
+;; (set! max-depth (max current-depth max-depth)))
+;; (define (pop)
+;; (if (null? s)
+;; (error "Empty stack -- POP")
+;; (let ((top (car s)))
+;; (set! s (cdr s))
+;; (set! current-depth (- current-depth 1))
+;; top)))
+;; (define (initialize)
+;; (set! s '())
+;; (set! number-pushes 0)
+;; (set! max-depth 0)
+;; (set! current-depth 0)
+;; 'done)
+;; (define (print-statistics)
+;; (newline)
+;; (display (list 'total-pushes '= number-pushes
+;; 'maximum-depth '= max-depth)))
+;; (define (dispatch message)
+;; (cond ((eq? message 'push) push)
+;; ((eq? message 'pop) (pop))
+;; ((eq? message 'initialize) (initialize))
+;; ((eq? message 'print-statistics)
+;; (print-statistics))
+;; (else
+;; (error "Unknown request -- STACK" message))))
+;; dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+;; Exercise 5.11. When we introduced save and restore in section 5.1.4, we didn't specify what would happen if you tried to restore a register that was not the last one saved, as in the sequence
+
+;; (save y)
+;; (save x)
+;; (restore y)
+
+;; There are several reasonable possibilities for the meaning of restore:
+
+;; a. (restore y) puts into y the last value saved on the stack, regardless of what register that value came from. This is the way our simulator behaves. Show how to take advantage of this behavior to eliminate one instruction from the Fibonacci machine of section 5.1.4 (figure 5.12).
+
+;; (assign n (reg val))
+;; (restore val)
+
+;; can now be shortened to
+
+;; (restore n)
+
+;; b. (restore y) puts into y the last value saved on the stack, but only if that value was saved from y; otherwise, it signals an error. Modify the simulator to behave this way. You will have to change save to put the register name on the stack along with the value.
+
+;; (define mismatch-machine
+;; (make-machine
+;; '(x y)
+;; '()
+;; '((assign x (const 5))
+;; (assign y (const 4))
+;; (save y)
+;; (save x)
+;; (restore y))))
+;; (start mismatch-machine)
+
+
+;; c. (restore y) puts into y the last value saved from y regardless of what other registers were saved after y and not restored. Modify the simulator to behave this way. You will have to associate a separate stack with each register. You should make the initialize-stack operation initialize all the register stacks.
+
+;; got bored, didn't implement
+
+(define (make-stack)
+ (let ((s '()))
+ (define (push x reg-name)
+ (let ((reg-pair (assoc reg-name s)))
+ (if (null? reg-pair)
+ (error "No stack for " reg-name)
+ (let ((stack (cdr reg-pair)))
+ (set-cdr! reg-pair (cons x (cdr reg-pair)))))))
+ (define (pop reg-name)
+ (let ((reg-pair (assoc reg-name s)))
+ (if (null? reg-pair)
+ (error "No stack for " reg-name)
+ (let ((stack (cdr reg-pair)))
+ (if (null? stack)
+ (error "Empty stack -- POP")
+ (let ((top (car stack)))
+ (set-cdr! reg-pair (cdr stack))
+ top))))))
+ (define (initialize)
+ (set! s '())
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) pop)
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack reg-name)
+ ((stack 'pop) reg-name))
+(define (push stack value reg-name)
+ ((stack 'push) value reg-name))
blob - /dev/null
blob + 900222b36c35004711eec27d076be5b7a11ba6ba (mode 644)
--- /dev/null
+++ ex5-12-c.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+;; Exercise 5.11. When we introduced save and restore in section 5.1.4, we didn't specify what would happen if you tried to restore a register that was not the last one saved, as in the sequence
+
+;; (save y)
+;; (save x)
+;; (restore y)
+
+;; There are several reasonable possibilities for the meaning of restore:
+
+;; a. (restore y) puts into y the last value saved on the stack, regardless of what register that value came from. This is the way our simulator behaves. Show how to take advantage of this behavior to eliminate one instruction from the Fibonacci machine of section 5.1.4 (figure 5.12).
+
+;; (assign n (reg val))
+;; (restore val)
+
+;; can now be shortened to
+
+;; (restore n)
+
+;; b. (restore y) puts into y the last value saved on the stack, but only if that value was saved from y; otherwise, it signals an error. Modify the simulator to behave this way. You will have to change save to put the register name on the stack along with the value.
+
+;; (define mismatch-machine
+;; (make-machine
+;; '(x y)
+;; '()
+;; '((assign x (const 5))
+;; (assign y (const 4))
+;; (save y)
+;; (save x)
+;; (restore y))))
+;; (start mismatch-machine)
+
+
+;; c. (restore y) puts into y the last value saved from y regardless of what other registers were saved after y and not restored. Modify the simulator to behave this way. You will have to associate a separate stack with each register. You should make the initialize-stack operation initialize all the register stacks.
blob - /dev/null
blob + eb444fbd2e289899c0206a6e490bf84843c48a53 (mode 644)
--- /dev/null
+++ ex5-12.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+;; Exercise 5.11. When we introduced save and restore in section 5.1.4, we didn't specify what would happen if you tried to restore a register that was not the last one saved, as in the sequence
+
+;; (save y)
+;; (save x)
+;; (restore y)
+
+;; There are several reasonable possibilities for the meaning of restore:
+
+;; a. (restore y) puts into y the last value saved on the stack, regardless of what register that value came from. This is the way our simulator behaves. Show how to take advantage of this behavior to eliminate one instruction from the Fibonacci machine of section 5.1.4 (figure 5.12).
+
+;; (assign n (reg val))
+;; (restore val)
+
+;; can now be shortened to
+
+;; (restore n)
+
+;; b. (restore y) puts into y the last value saved on the stack, but only if that value was saved from y; otherwise, it signals an error. Modify the simulator to behave this way. You will have to change save to put the register name on the stack along with the value.
+
+
+
+;; c. (restore y) puts into y the last value saved from y regardless of what other registers were saved after y and not restored. Modify the simulator to behave this way. You will have to associate a separate stack with each register. You should make the initialize-stack operation initialize all the register stacks.
blob - /dev/null
blob + 7632deb95048dcefe00affad9d37ebed1a25d37d (mode 644)
--- /dev/null
+++ ex5-12.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
blob - /dev/null
blob + a4bbf5edd53a9142e30b10e4a2fd8f23d9430347 (mode 644)
--- /dev/null
+++ ex5-14.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+;; Exercise 5.14. Measure the number of pushes and the maximum stack depth required to compute n! for various small values of n using the factorial machine shown in figure 5.11. From your data determine formulas in terms of n for the total number of push operations and the maximum stack depth used in computing n! for any n > 1. Note that each of these is a linear function of n and is thus determined by two constants. In order to get the statistics printed, you will have to augment the factorial machine with instructions to initialize the stack and print the statistics. You may want to also modify the machine so that it repeatedly reads a value for n, computes the factorial, and prints the result (as we did for the GCD machine in figure 5.4), so that you will not have to repeatedly invoke get-register-contents, set-register-contents!, and start.
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+
+(define (test-fact-statistics n)
+ (set-register-contents! fact-rec 'n n)
+ (newline)
+ (display "n = ")
+ (display n)
+ (start fact-rec)
+ (newline))
+
+(test-fact-statistics 1)
+(test-fact-statistics 2)
+(test-fact-statistics 3)
+(test-fact-statistics 4)
+(test-fact-statistics 5)
+(test-fact-statistics 6)
+(test-fact-statistics 7)
+(test-fact-statistics 8)
+(test-fact-statistics 9)
+(test-fact-statistics 10)
+
+;; push operations is 4n-6 for n >= 2, maximum depth is 2n-2
blob - /dev/null
blob + 900222b36c35004711eec27d076be5b7a11ba6ba (mode 644)
--- /dev/null
+++ ex5-14.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+;; Exercise 5.11. When we introduced save and restore in section 5.1.4, we didn't specify what would happen if you tried to restore a register that was not the last one saved, as in the sequence
+
+;; (save y)
+;; (save x)
+;; (restore y)
+
+;; There are several reasonable possibilities for the meaning of restore:
+
+;; a. (restore y) puts into y the last value saved on the stack, regardless of what register that value came from. This is the way our simulator behaves. Show how to take advantage of this behavior to eliminate one instruction from the Fibonacci machine of section 5.1.4 (figure 5.12).
+
+;; (assign n (reg val))
+;; (restore val)
+
+;; can now be shortened to
+
+;; (restore n)
+
+;; b. (restore y) puts into y the last value saved on the stack, but only if that value was saved from y; otherwise, it signals an error. Modify the simulator to behave this way. You will have to change save to put the register name on the stack along with the value.
+
+;; (define mismatch-machine
+;; (make-machine
+;; '(x y)
+;; '()
+;; '((assign x (const 5))
+;; (assign y (const 4))
+;; (save y)
+;; (save x)
+;; (restore y))))
+;; (start mismatch-machine)
+
+
+;; c. (restore y) puts into y the last value saved from y regardless of what other registers were saved after y and not restored. Modify the simulator to behave this way. You will have to associate a separate stack with each register. You should make the initialize-stack operation initialize all the register stacks.
blob - /dev/null
blob + 713c2544f906c68d711ccd6f5e8ffd3179804888 (mode 644)
--- /dev/null
+++ ex5-15.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define (test-fact-statistics n)
+ (set-register-contents! fact-rec 'n n)
+ (newline)
+ (display "n = ")
+ (display n)
+ (start fact-rec)
+ (newline))
+
+;; (test-fact-statistics 1)
+;; (test-fact-statistics 2)
+;; (test-fact-statistics 3)
+;; (test-fact-statistics 4)
+;; (test-fact-statistics 5)
+;; (test-fact-statistics 6)
+;; (test-fact-statistics 7)
+;; (test-fact-statistics 8)
+;; (test-fact-statistics 9)
+;; (test-fact-statistics 10)
+
blob - /dev/null
blob + a4bbf5edd53a9142e30b10e4a2fd8f23d9430347 (mode 644)
--- /dev/null
+++ ex5-15.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+;; Exercise 5.14. Measure the number of pushes and the maximum stack depth required to compute n! for various small values of n using the factorial machine shown in figure 5.11. From your data determine formulas in terms of n for the total number of push operations and the maximum stack depth used in computing n! for any n > 1. Note that each of these is a linear function of n and is thus determined by two constants. In order to get the statistics printed, you will have to augment the factorial machine with instructions to initialize the stack and print the statistics. You may want to also modify the machine so that it repeatedly reads a value for n, computes the factorial, and prints the result (as we did for the GCD machine in figure 5.4), so that you will not have to repeatedly invoke get-register-contents, set-register-contents!, and start.
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+
+(define (test-fact-statistics n)
+ (set-register-contents! fact-rec 'n n)
+ (newline)
+ (display "n = ")
+ (display n)
+ (start fact-rec)
+ (newline))
+
+(test-fact-statistics 1)
+(test-fact-statistics 2)
+(test-fact-statistics 3)
+(test-fact-statistics 4)
+(test-fact-statistics 5)
+(test-fact-statistics 6)
+(test-fact-statistics 7)
+(test-fact-statistics 8)
+(test-fact-statistics 9)
+(test-fact-statistics 10)
+
+;; push operations is 4n-6 for n >= 2, maximum depth is 2n-2
blob - /dev/null
blob + f9c89a04a74f3bd6935e7ef3521debbec5cae693 (mode 644)
--- /dev/null
+++ ex5-2.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (receive insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels))
+ (receive (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+;; (define (factorial n)
+;; (define (iter product counter)
+;; (if (> counter n)
+;; product
+;; (iter (* counter product)
+;; (+ counter 1))))
+;; (iter 1 1))
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+
+;; Exercise 5.3. Design a machine to compute square roots using Newton's method, as described in section 1.1.7:
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+;; Begin by assuming that good-enough? and improve operations are available as primitives. Then show how to expand these in terms of arithmetic operations. Describe each version of the sqrt machine design by drawing a data-path diagram and writing a controller definition in the register-machine language.
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
blob - /dev/null
blob + 8bd1c1449255eac74a13a4ad1f35525fde9f9cd5 (mode 644)
--- /dev/null
+++ ex5-2.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (receive insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels))
+ (receive (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+
+;; Exercise 5.1. Design a register machine to compute factorials using the iterative algorithm specified by the following procedure. Draw data-path and controller diagrams for this machine.
+
+(define (factorial n)
+ (define (iter product counter)
+ (if (> counter n)
+ product
+ (iter (* counter product)
+ (+ counter 1))))
+ (iter 1 1))
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+
blob - /dev/null
blob + 118049408226d18e2e053921bb3d9436a7b53394 (mode 644)
--- /dev/null
+++ ex5-20.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+;; Exercise 5.20. Draw the box-and-pointer representation and the memory-vector representation (as in figure 5.14) of the list structure produced by
+
+(define x (cons 1 2))
+(define y (list x x))
+
+;; with the free pointer initially p1. What is the final value of free ? What pointers represent the values of x and y ?
+
+;; (cons 1 2) --> p1
+;; (cons x '()) --> p2
+;; (cons x (cons x '())) --> p3
+;; so, x --> p1 and y --> p3
+
+;; (cons x '()) should actually be referred to using p2 and (cons x (cons x '())) should be referred to with p3 because scheme is an applicative order language and so it seems to me that (cons x '()) needs to be evaluated first
+
+;; free's final value is p4
blob - /dev/null
blob + 713c2544f906c68d711ccd6f5e8ffd3179804888 (mode 644)
--- /dev/null
+++ ex5-20.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define (test-fact-statistics n)
+ (set-register-contents! fact-rec 'n n)
+ (newline)
+ (display "n = ")
+ (display n)
+ (start fact-rec)
+ (newline))
+
+;; (test-fact-statistics 1)
+;; (test-fact-statistics 2)
+;; (test-fact-statistics 3)
+;; (test-fact-statistics 4)
+;; (test-fact-statistics 5)
+;; (test-fact-statistics 6)
+;; (test-fact-statistics 7)
+;; (test-fact-statistics 8)
+;; (test-fact-statistics 9)
+;; (test-fact-statistics 10)
+
blob - /dev/null
blob + 9ffb60c7c2233fa172fed671a059580a25dd95a8 (mode 644)
--- /dev/null
+++ ex5-21.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+;; Exercise 5.21. Implement register machines for the following procedures. Assume that the list-structure memory operations are available as machine primitives.
+
+;; a. Recursive count-leaves:
+
+(define (count-leaves tree)
+ (cond ((null? tree) 0)
+ ((not (pair? tree)) 1)
+ (else (+ (count-leaves (car tree))
+ (count-leaves (cdr tree))))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+;; b. Recursive count-leaves with explicit counter:
+
+(define (count-leaves tree)
+ (define (count-iter tree n)
+ (cond ((null? tree) n)
+ ((not (pair? tree)) (+ n 1))
+ (else (count-iter (cdr tree)
+ (count-iter (car tree) n)))))
+ (count-iter tree 0))
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(define (count-leaves tree)
+ (define (count-iter tree n)
+ (cond ((null? tree) n)
+ ((not (pair? tree)) (+ n 1))
+ (else (count-iter (cdr tree)
+ (count-iter (car tree) n)))))
+ (count-iter tree 0))
+
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
blob - /dev/null
blob + 7617877983c6eb278aa974e855d1b58d9d59b0c9 (mode 644)
--- /dev/null
+++ ex5-22.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+;; Exercise 5.22. Exercise 3.12 of section 3.3.1 presented an append procedure that appends two lists to form a new list and an append! procedure that splices two lists together. Design a register machine to implement each of these procedures. Assume that the list-structure memory operations are available as primitive operations.
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
blob - /dev/null
blob + 16ea445348dcc732590e6d515377102cfd79d792 (mode 644)
--- /dev/null
+++ ex5-22.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+;; Exercise 5.21. Implement register machines for the following procedures. Assume that the list-structure memory operations are available as machine primitives.
+
+;; a. Recursive count-leaves:
+
+(define (count-leaves tree)
+ (cond ((null? tree) 0)
+ ((not (pair? tree)) 1)
+ (else (+ (count-leaves (car tree))
+ (count-leaves (cdr tree))))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+;; b. Recursive count-leaves with explicit counter:
+
+(define (count-leaves tree)
+ (define (count-iter tree n)
+ (cond ((null? tree) n)
+ ((not (pair? tree)) (+ n 1))
+ (else (count-iter (cdr tree)
+ (count-iter (car tree) n)))))
+ (count-iter tree 0))
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(define (count-leaves tree)
+ (define (count-iter tree n)
+ (cond ((null? tree) n)
+ ((not (pair? tree)) (+ n 1))
+ (else (count-iter (cdr tree)
+ (count-iter (car tree) n)))))
+ (count-iter tree 0))
+
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
blob - /dev/null
blob + 5bcb0863b0f227bff50447daaf40507feba164b7 (mode 644)
--- /dev/null
+++ ex5-23.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev)
+ eceval-operations
+ '(
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop)))))
+
+(start eceval)
+
+;; Exercise 5.23. Extend the evaluator to handle derived expressions such as cond, let, and so on (section 4.1.2). You may ``cheat'' and assume that the syntax transformers such as cond->if are available as machine operations.28
blob - /dev/null
blob + e4c6c83decbad9680cf3e4b512c67052420657b7 (mode 644)
--- /dev/null
+++ ex5-23.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; 5 more times
+
+eval-dispatch
+(test (op self-evaluating?) (reg exp))
+(branch (label ev-self-eval))
+(test (op quoted?) (reg exp))
+(branch (label ev-quoted))
+(test (op variable?) (reg exp))
+(branch (label ev-variable))
+(test (op assignment?) (reg exp))
+(branch (label ev-assignment))
+(test (op definition?) (reg exp))
+(branch (label ev-definition))
+(test (op if?) (reg exp))
+(branch (label ev-if))
+(test (op begin?) (reg exp))
+(branch (label ev-begin))
+(test (op lambda?) (reg exp))
+(branch (label ev-lambda))
+(test (op application?) (reg exp))
+(branch (label ev-application))
+(goto (label unknown-expression-type))
+
+ev-self-eval
+(assign val (reg exp))
+(goto (reg continue))
+ev-quoted
+(assign val (op text-of-quotation) (reg exp))
+(goto (reg continue))
+ev-variable
+(assign val (op lookup-variable-value) (reg exp) (reg env))
+(goto (reg continue))
+ev-assignment
+(assign unev (op assignment-variable) (reg exp))
+(save unev)
+(save env)
+(save continue)
+(assign continue (label ev-assignment1))
+(assign exp (op assignment-value) (reg exp))
+(goto (label eval-dispatch))
+ev-assignment1
+(restore continue)
+(restore env)
+(restore unev)
+(perform (op set-variable-value!) (reg unev) (reg val) (reg env))
+(assign val (const ok))
+(goto (reg continue))
+
+ev-definition
+(assign unev (op definition-variable) (reg exp))
+(save unev)
+(save env)
+(assign exp (op definition-value) (reg exp))
+(save continue)
+(assign continue (label ev-definition1))
+(goto (label eval-dispatch))
+ev-definition1
+(restore continue)
+(restore env)
+(restore unev)
+(perform (op define-variable!) (reg unev) (reg val) (reg env))
+(assign val (const ok))
+(goto (reg continue))
+
+ev-if
+(save env)
+(save exp)
+(save continue)
+(assign exp (op if-predicate) (reg exp))
+(assign continue (label if-decide))
+(goto (label eval-dispatch))
+if-decide
+(restore continue)
+(restore exp)
+(restore env)
+(test (op true?) (reg val))
+(branch (label if-consequent))
+if-alternative
+(assign exp (op if-alternative) (reg exp))
+(goto (label eval-dispatch))
+if-consequent
+(assign exp (op if-consequent) (reg exp))
+(goto (label eval-dispatch))
+
+ev-lambda
+(assign unev (op lambda-parameters) (reg exp))
+(assign exp (op lambda-body) (reg exp))
+(assign val (op make-procedure) (reg unev) (reg exp) (reg env))
+(goto (reg continue))
+
+ev-begin
+(save continue)
+(assign unev (op begin-actions) (reg exp))
+(goto (eval-sequence))
+
+ev-application
+(save continue)
+(assign unev (op operands) (reg exp))
+(save unev)
+(save env)
+(assign exp (op operator) (reg exp))
+(assign continue (label ev-appl-did-operator))
+(goto (label eval-dispatch))
+ev-appl-did-operator
+(restore env)
+(restore unev)
+(assign proc (reg val))
+(assign argl (op empty-arglist))
+(test (op no-operands?) (reg unev))
+(branch (label apply-dispatch))
+(save proc)
+eval-operands
+(save argl)
+(assign exp (op first-operand) (reg unev))
+(test (op last-operand?) (reg unev))
+(branch (label ev-appl-last-operand))
+(save unev)
+(save env)
+(assign continue (label ev-appl-accum-arg))
+ev-appl-last-operand
+(assign continue (label ev-appl-accum-last-arg))
+(goto (label eval-dispatch))
+ev-appl-accum-last-arg
+(restore argl)
+(restore proc)
+(assign argl (op adjoin-arg) (reg val) (reg argl))
+(goto (label apply-dispatch))
+ev-appl-accum-arg
+(restore env)
+(restore unev)
+(restore argl)
+(assign argl (op adjoin-arg) (reg val) (reg argl))
+(assign unev (op rest-operands) (reg unev))
+(goto (label eval-operands))
+
+apply-dispatch
+(test (op primitive-procedure?) (reg proc))
+(branch (label apply-primitive-procedure))
+(test (op compound-procedure?) (reg proc))
+(branch (label compound-apply))
+(goto (label unknown-procedure-type))
+
+
+apply-primitive-procedure
+(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
+(restore continue)
+(goto (reg continue))
+
+compound-apply
+(assign env (op procedure-environment) (reg proc))
+(assign unev (op procedure-parameters) (reg proc))
+(assign env (op extend-environment) (reg unev) (reg argl) (reg env))
+(assign unev (op procedure-body) (reg proc))
+(goto (label eval-sequence))
+
+eval-sequence
+(assign exp (op first-exp) (reg unev))
+(test (op last-exp?) (reg unev))
+(branch (label ev-last-exp))
+(save unev)
+(save env)
+(assign continue (after-eval-operand))
+(goto (label eval-dispatch))
+after-eval-operand
+(restore env)
+(restore unev)
+(assign unev (op rest-operands) (reg unev))
+(goto (label eval-sequence))
+
+ev-last-exp
+(restore continue)
+(goto (label eval-dispatch))
+
+ev-sequence
+(test (op no-exps?) (reg unev))
+(branch (label no-exps))
+(assign exp (op first-operand) (reg unev))
+(save env)
+(save unev)
+(assign continue (ev-sequence-continue))
+(goto (label eval-dispatch))
+ev-sequence-continue
+(restore unev)
+(restore env)
+(assign unev (op rest-operands) (reg unev))
+(goto (label ev-sequence))
+
+no-exps
+(restore continue)
+(goto (reg continue))
+
+
+read-eval-print-loop
+(perform (op initialize-stack))
+(perform (op prompt-for-input) (const ";;; EC-Eval Input: "))
+(assign exp (op read))
+(assign env (op get-global-environment))
+(assign continue (label print-result))
+(goto (label eval-dispatch))
+print-result
+(perform (op print-stack-statistics))
+(perform (op announce-output) (const ";;; EC-Eval Output: "))
+(perform (op user-print) (reg val))
+(goto (label read-eval-print-loop))
+
+unknown-expression-type
+(assign val (const unknown-expression-type))
+(goto (label signal-error))
+unknown-procedure-type
+(restore continue)
+(assign val (const unknown-procedure-type))
+(goto (label signal-error))
+signal-error
+(perform (op user-print) (reg val))
+(goto (label read-eval-print-loop))
+
+(define eceval
+ (make-machine
+ '(exp env proc val continue unev argl)
+ eceval-operations
+ '(
+ read-eval-print-loop
+ )))
+
+(define eceval-operations
+ `((self-evaluating? ,self-evaluating?)))
+(define the-global-environment (setup-environment))
+(start eceval)
+
blob - /dev/null
blob + 22f75eda70cb7974eee9ea1075cb3b079d3af59f (mode 644)
--- /dev/null
+++ ex5-23b.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-loop))
+ (goto (label eval-dispatch))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(test-interpret
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+
+;; Exercise 5.23. Extend the evaluator to handle derived expressions such as cond, let, and so on (section 4.1.2). You may ``cheat'' and assume that the syntax transformers such as cond->if are available as machine operations.28
+
+;; procedure definition / application
+
+(test-interpret
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; cond
+
+(test-interpret
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+(test-interpret
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)))
+ false)
+(test-interpret
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)
+ (else 4)))
+ 4)
+
+;; let
+
+(test-interpret
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
blob - /dev/null
blob + eacf5c75783b0a476fb7656a235981095c49a96a (mode 644)
--- /dev/null
+++ ex5-23b.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-loop))
+ (goto (label eval-dispatch))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(test-interpret
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+
+;; Exercise 5.23. Extend the evaluator to handle derived expressions such as cond, let, and so on (section 4.1.2). You may ``cheat'' and assume that the syntax transformers such as cond->if are available as machine operations.28
+
+(test-interpret
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+
+(test-interpret
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
blob - /dev/null
blob + 971db0c8aa30dff76158b79142a0735dc78516db (mode 644)
--- /dev/null
+++ ex5-24.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (no-clauses? clauses) (null? clauses))
+(define (first-clause clauses) (car clauses))
+(define (rest-clauses clauses) (cdr clauses))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+;; (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (cond-clauses ,cond-clauses)
+ (no-clauses? ,no-clauses?)
+ (first-clause ,first-clause)
+ (cond-else-clause? ,cond-else-clause?)
+ (cond-predicate ,cond-predicate)
+ (rest-clauses ,rest-clauses)
+ (cond-actions ,cond-actions)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-loop))
+ (goto (label eval-dispatch))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ;; ev-cond
+ ;; (assign exp (op cond->if) (reg exp))
+ ;; (goto (label eval-dispatch))
+
+ ev-cond
+ (save continue)
+ (assign unev (op cond-clauses) (reg exp))
+ ev-clause
+ (test (op no-clauses?) (reg unev))
+ (branch (label ev-no-clauses))
+ (assign exp (op first-clause) (reg unev))
+ (test (op cond-else-clause?) (reg exp))
+ (branch (label ev-clause-actions))
+ (save exp)
+ (save unev)
+ (save env)
+ (assign exp (op cond-predicate) (reg exp))
+ (assign continue (label ev-clause-decide))
+ (goto (label eval-dispatch))
+ ev-clause-decide
+ (restore env)
+ (restore unev)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-clause-actions))
+ (assign unev (op rest-clauses) (reg unev))
+ (goto (label ev-clause))
+ ev-no-clauses
+ (assign val (op lookup-variable-value) (const false) (reg env))
+ (restore continue)
+ (goto (reg continue))
+ ev-clause-actions
+ (assign unev (op cond-actions) (reg exp))
+ (goto (label ev-sequence))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+;; procedure definition / application
+
+(test-interpret
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; cond
+
+(test-interpret
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+(test-interpret
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)))
+ false)
+(test-interpret
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)
+ (else 4)))
+ 4)
+
+;; let
+
+(test-interpret
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
+
+;; Exercise 5.24. Implement cond as a new basic special form without reducing it to if. You will have to construct a loop that tests the predicates of successive cond clauses until you find one that is true, and then use ev-sequence to evaluate the actions of the clause.
blob - /dev/null
blob + eacf5c75783b0a476fb7656a235981095c49a96a (mode 644)
--- /dev/null
+++ ex5-24.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-loop))
+ (goto (label eval-dispatch))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(test-interpret
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+
+;; Exercise 5.23. Extend the evaluator to handle derived expressions such as cond, let, and so on (section 4.1.2). You may ``cheat'' and assume that the syntax transformers such as cond->if are available as machine operations.28
+
+(test-interpret
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+
+(test-interpret
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
blob - /dev/null
blob + 56a0829be513552400a2eb327881a56e1804166c (mode 644)
--- /dev/null
+++ ex5-26.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (stack-statistics)
+ (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ ((eq? message 'stack-statistics)
+ (stack-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))
+ (list 'stack-statistics
+ (lambda () (stack 'stack-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-continue))
+ (goto (label eval-dispatch))
+
+ eval-continue
+ (assign unev (op stack-statistics))
+ (goto (label eval-loop))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(define (test-interpret-stack code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected)
+ (display (get-register-contents eceval 'unev))
+ (newline))
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; procedure definition / application
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; cond
+
+(test-interpret-stack
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret-stack
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)))
+ false)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)
+ (else 4)))
+ 4)
+
+;; let
+
+(test-interpret-stack
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret-stack
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret-stack
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret-stack
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
+
+;; Exercise 5.26. Use the monitored stack to explore the tail-recursive property of the evaluator (section 5.4.2). Start the evaluator and define the iterative factorial procedure from section 1.2.1:
+
+(test-interpret-stack
+ '((define (factorial n)
+ (define (iter product counter)
+ (if (> counter n)
+ product
+ (iter (* counter product)
+ (+ counter 1))))
+ (iter 1 1))
+ (factorial 1))
+ 1)
+(test-interpret-stack
+ '((factorial 2))
+ 2)
+(test-interpret-stack
+ '((factorial 3))
+ 6)
+(test-interpret-stack
+ '((factorial 4))
+ 24)
+(test-interpret-stack
+ '((factorial 5))
+ 120)
+(test-interpret-stack
+ '((factorial 6))
+ 720)
+
+;; Run the procedure with some small values of n. Record the maximum stack depth and the number of pushes required to compute n! for each of these values.
+
+;; a. You will find that the maximum depth required to evaluate n! is independent of n. What is that depth?
+
+;; 10
+
+;; b. Determine from your data a formula in terms of n for the total number of push operations used in evaluating n! for any n > 1. Note that the number of operations used is a linear function of n and is thus determined by two constants.
+
+;; 35n + 29
blob - /dev/null
blob + 22f75eda70cb7974eee9ea1075cb3b079d3af59f (mode 644)
--- /dev/null
+++ ex5-26.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-loop))
+ (goto (label eval-dispatch))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(test-interpret
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+
+;; Exercise 5.23. Extend the evaluator to handle derived expressions such as cond, let, and so on (section 4.1.2). You may ``cheat'' and assume that the syntax transformers such as cond->if are available as machine operations.28
+
+;; procedure definition / application
+
+(test-interpret
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; cond
+
+(test-interpret
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+(test-interpret
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)))
+ false)
+(test-interpret
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)
+ (else 4)))
+ 4)
+
+;; let
+
+(test-interpret
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
blob - /dev/null
blob + 4f21526a30177b2aed6eea54efe8e419378209c3 (mode 644)
--- /dev/null
+++ ex5-27.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (stack-statistics)
+ (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ ((eq? message 'stack-statistics)
+ (stack-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))
+ (list 'stack-statistics
+ (lambda () (stack 'stack-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-continue))
+ (goto (label eval-dispatch))
+
+ eval-continue
+ (assign unev (op stack-statistics))
+ (goto (label eval-loop))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(define (test-interpret-stack code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected)
+ (display (get-register-contents eceval 'unev))
+ (newline))
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; procedure definition / application
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; cond
+
+(test-interpret-stack
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret-stack
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)))
+ false)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)
+ (else 4)))
+ 4)
+
+;; let
+
+(test-interpret-stack
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret-stack
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret-stack
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret-stack
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
+
+;; Exercise 5.26. Use the monitored stack to explore the tail-recursive property of the evaluator (section 5.4.2). Start the evaluator and define the iterative factorial procedure from section 1.2.1:
+
+(test-interpret-stack
+ '((define (factorial n)
+ (define (iter product counter)
+ (if (> counter n)
+ product
+ (iter (* counter product)
+ (+ counter 1))))
+ (iter 1 1))
+ (factorial 1))
+ 1)
+(test-interpret-stack
+ '((factorial 2))
+ 2)
+(test-interpret-stack
+ '((factorial 3))
+ 6)
+(test-interpret-stack
+ '((factorial 4))
+ 24)
+(test-interpret-stack
+ '((factorial 5))
+ 120)
+(test-interpret-stack
+ '((factorial 6))
+ 720)
+(test-interpret-stack
+ '((factorial 7))
+ 5040)
+(test-interpret-stack
+ '((factorial 8))
+ 40320)
+(test-interpret-stack
+ '((factorial 9))
+ 362880)
+
+;; Run the procedure with some small values of n. Record the maximum stack depth and the number of pushes required to compute n! for each of these values.
+
+;; a. You will find that the maximum depth required to evaluate n! is independent of n. What is that depth?
+
+;; 10
+
+;; b. Determine from your data a formula in terms of n for the total number of push operations used in evaluating n! for any n > 1. Note that the number of operations used is a linear function of n and is thus determined by two constants.
+
+;; 35n + 29
+
+;; Exercise 5.27. For comparison with exercise 5.26, explore the behavior of the following procedure for computing factorials recursively:
+
+(test-interpret-stack
+ '((define (fact-rec n)
+ (if (= n 1)
+ 1
+ (* (fact-rec (- n 1)) n)))
+ (fact-rec 1))
+ 1)
+(test-interpret-stack
+ '((fact-rec 2))
+ 2)
+(test-interpret-stack
+ '((fact-rec 3))
+ 6)
+(test-interpret-stack
+ '((fact-rec 4))
+ 24)
+(test-interpret-stack
+ '((fact-rec 5))
+ 120)
+(test-interpret-stack
+ '((fact-rec 6))
+ 720)
+(test-interpret-stack
+ '((fact-rec 7))
+ 5040)
+(test-interpret-stack
+ '((fact-rec 8))
+ 40320)
+(test-interpret-stack
+ '((fact-rec 9))
+ 362880)
+(test-interpret-stack
+ '((fact-rec 10))
+ 3628800)
+
+;; total-pushes = 32n - 16
+;; max-depth = 5n + 3
+
+;; Exercise 5.28. Modify the definition of the evaluator by changing eval-sequence as described in section 5.4.2 so that the evaluator is no longer tail-recursive. Rerun your experiments from exercises 5.26 and 5.27 to demonstrate that both versions of the factorial procedure now require space that grows linearly with their input.
blob - /dev/null
blob + 56a0829be513552400a2eb327881a56e1804166c (mode 644)
--- /dev/null
+++ ex5-27.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (stack-statistics)
+ (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ ((eq? message 'stack-statistics)
+ (stack-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))
+ (list 'stack-statistics
+ (lambda () (stack 'stack-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-continue))
+ (goto (label eval-dispatch))
+
+ eval-continue
+ (assign unev (op stack-statistics))
+ (goto (label eval-loop))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(define (test-interpret-stack code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected)
+ (display (get-register-contents eceval 'unev))
+ (newline))
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; procedure definition / application
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; cond
+
+(test-interpret-stack
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret-stack
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)))
+ false)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)
+ (else 4)))
+ 4)
+
+;; let
+
+(test-interpret-stack
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret-stack
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret-stack
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret-stack
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
+
+;; Exercise 5.26. Use the monitored stack to explore the tail-recursive property of the evaluator (section 5.4.2). Start the evaluator and define the iterative factorial procedure from section 1.2.1:
+
+(test-interpret-stack
+ '((define (factorial n)
+ (define (iter product counter)
+ (if (> counter n)
+ product
+ (iter (* counter product)
+ (+ counter 1))))
+ (iter 1 1))
+ (factorial 1))
+ 1)
+(test-interpret-stack
+ '((factorial 2))
+ 2)
+(test-interpret-stack
+ '((factorial 3))
+ 6)
+(test-interpret-stack
+ '((factorial 4))
+ 24)
+(test-interpret-stack
+ '((factorial 5))
+ 120)
+(test-interpret-stack
+ '((factorial 6))
+ 720)
+
+;; Run the procedure with some small values of n. Record the maximum stack depth and the number of pushes required to compute n! for each of these values.
+
+;; a. You will find that the maximum depth required to evaluate n! is independent of n. What is that depth?
+
+;; 10
+
+;; b. Determine from your data a formula in terms of n for the total number of push operations used in evaluating n! for any n > 1. Note that the number of operations used is a linear function of n and is thus determined by two constants.
+
+;; 35n + 29
blob - /dev/null
blob + 69fb09b250b957450e9da4919280a7877e6d0fbd (mode 644)
--- /dev/null
+++ ex5-28.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (stack-statistics)
+ (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ ((eq? message 'stack-statistics)
+ (stack-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))
+ (list 'stack-statistics
+ (lambda () (stack 'stack-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+(define (no-more-exps? seq) (null? seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (no-more-exps? ,no-more-exps?)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-continue))
+ (goto (label eval-dispatch))
+
+ eval-continue
+ (assign unev (op stack-statistics))
+ (goto (label eval-loop))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ;; ev-sequence
+ ;; (assign exp (op first-exp) (reg unev))
+ ;; (test (op last-exp?) (reg unev))
+ ;; (branch (label ev-sequence-last-exp))
+ ;; (save unev)
+ ;; (save env)
+ ;; (assign continue (label ev-sequence-continue))
+ ;; (goto (label eval-dispatch))
+ ;; ev-sequence-continue
+ ;; (restore env)
+ ;; (restore unev)
+ ;; (assign unev (op rest-exps) (reg unev))
+ ;; (goto (label ev-sequence))
+ ;; ev-sequence-last-exp
+ ;; (restore continue)
+ ;; (goto (label eval-dispatch))
+
+ ev-sequence
+ (test (op no-more-exps?) (reg unev))
+ (branch (label ev-sequence-done))
+ (save unev)
+ (save env)
+ (assign exp (op first-exp) (reg unev))
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-done
+ (restore continue)
+ (goto (reg continue))
+
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(define (test-interpret-stack code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected)
+ (display (get-register-contents eceval 'unev))
+ (newline))
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; procedure definition / application
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; cond
+
+(test-interpret-stack
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret-stack
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)))
+ false)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)
+ (else 4)))
+ 4)
+
+;; let
+
+(test-interpret-stack
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret-stack
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret-stack
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret-stack
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
+
+;; Exercise 5.26. Use the monitored stack to explore the tail-recursive property of the evaluator (section 5.4.2). Start the evaluator and define the iterative factorial procedure from section 1.2.1:
+
+(test-interpret-stack
+ '((define (factorial n)
+ (define (iter product counter)
+ (if (> counter n)
+ product
+ (iter (* counter product)
+ (+ counter 1))))
+ (iter 1 1))
+ (factorial 1))
+ 1)
+(test-interpret-stack
+ '((factorial 2))
+ 2)
+(test-interpret-stack
+ '((factorial 3))
+ 6)
+(test-interpret-stack
+ '((factorial 4))
+ 24)
+(test-interpret-stack
+ '((factorial 5))
+ 120)
+(test-interpret-stack
+ '((factorial 6))
+ 720)
+(test-interpret-stack
+ '((factorial 7))
+ 5040)
+(test-interpret-stack
+ '((factorial 8))
+ 40320)
+(test-interpret-stack
+ '((factorial 9))
+ 362880)
+
+;; Run the procedure with some small values of n. Record the maximum stack depth and the number of pushes required to compute n! for each of these values.
+
+;; a. You will find that the maximum depth required to evaluate n! is independent of n. What is that depth?
+
+;; 10
+
+;; b. Determine from your data a formula in terms of n for the total number of push operations used in evaluating n! for any n > 1. Note that the number of operations used is a linear function of n and is thus determined by two constants.
+
+;; 35n + 29
+
+;; Exercise 5.27. For comparison with exercise 5.26, explore the behavior of the following procedure for computing factorials recursively:
+
+(test-interpret-stack
+ '((define (fact-rec n)
+ (if (= n 1)
+ 1
+ (* (fact-rec (- n 1)) n)))
+ (fact-rec 1))
+ 1)
+(test-interpret-stack
+ '((fact-rec 2))
+ 2)
+(test-interpret-stack
+ '((fact-rec 3))
+ 6)
+(test-interpret-stack
+ '((fact-rec 4))
+ 24)
+(test-interpret-stack
+ '((fact-rec 5))
+ 120)
+(test-interpret-stack
+ '((fact-rec 6))
+ 720)
+(test-interpret-stack
+ '((fact-rec 7))
+ 5040)
+(test-interpret-stack
+ '((fact-rec 8))
+ 40320)
+(test-interpret-stack
+ '((fact-rec 9))
+ 362880)
+(test-interpret-stack
+ '((fact-rec 10))
+ 3628800)
+
+;; total-pushes = 32n - 16
+;; max-depth = 5n + 3
+
+;; Exercise 5.28. Modify the definition of the evaluator by changing eval-sequence as described in section 5.4.2 so that the evaluator is no longer tail-recursive. Rerun your experiments from exercises 5.26 and 5.27 to demonstrate that both versions of the factorial procedure now require space that grows linearly with their input.
+
+;; max depth for fact-iter: 3n + 14
+;; max depth for fact-rec: 8n + 3
blob - /dev/null
blob + 4f21526a30177b2aed6eea54efe8e419378209c3 (mode 644)
--- /dev/null
+++ ex5-28.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (stack-statistics)
+ (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ ((eq? message 'stack-statistics)
+ (stack-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))
+ (list 'stack-statistics
+ (lambda () (stack 'stack-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-continue))
+ (goto (label eval-dispatch))
+
+ eval-continue
+ (assign unev (op stack-statistics))
+ (goto (label eval-loop))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(define (test-interpret-stack code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected)
+ (display (get-register-contents eceval 'unev))
+ (newline))
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; procedure definition / application
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; cond
+
+(test-interpret-stack
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret-stack
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)))
+ false)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)
+ (else 4)))
+ 4)
+
+;; let
+
+(test-interpret-stack
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret-stack
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret-stack
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret-stack
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
+
+;; Exercise 5.26. Use the monitored stack to explore the tail-recursive property of the evaluator (section 5.4.2). Start the evaluator and define the iterative factorial procedure from section 1.2.1:
+
+(test-interpret-stack
+ '((define (factorial n)
+ (define (iter product counter)
+ (if (> counter n)
+ product
+ (iter (* counter product)
+ (+ counter 1))))
+ (iter 1 1))
+ (factorial 1))
+ 1)
+(test-interpret-stack
+ '((factorial 2))
+ 2)
+(test-interpret-stack
+ '((factorial 3))
+ 6)
+(test-interpret-stack
+ '((factorial 4))
+ 24)
+(test-interpret-stack
+ '((factorial 5))
+ 120)
+(test-interpret-stack
+ '((factorial 6))
+ 720)
+(test-interpret-stack
+ '((factorial 7))
+ 5040)
+(test-interpret-stack
+ '((factorial 8))
+ 40320)
+(test-interpret-stack
+ '((factorial 9))
+ 362880)
+
+;; Run the procedure with some small values of n. Record the maximum stack depth and the number of pushes required to compute n! for each of these values.
+
+;; a. You will find that the maximum depth required to evaluate n! is independent of n. What is that depth?
+
+;; 10
+
+;; b. Determine from your data a formula in terms of n for the total number of push operations used in evaluating n! for any n > 1. Note that the number of operations used is a linear function of n and is thus determined by two constants.
+
+;; 35n + 29
+
+;; Exercise 5.27. For comparison with exercise 5.26, explore the behavior of the following procedure for computing factorials recursively:
+
+(test-interpret-stack
+ '((define (fact-rec n)
+ (if (= n 1)
+ 1
+ (* (fact-rec (- n 1)) n)))
+ (fact-rec 1))
+ 1)
+(test-interpret-stack
+ '((fact-rec 2))
+ 2)
+(test-interpret-stack
+ '((fact-rec 3))
+ 6)
+(test-interpret-stack
+ '((fact-rec 4))
+ 24)
+(test-interpret-stack
+ '((fact-rec 5))
+ 120)
+(test-interpret-stack
+ '((fact-rec 6))
+ 720)
+(test-interpret-stack
+ '((fact-rec 7))
+ 5040)
+(test-interpret-stack
+ '((fact-rec 8))
+ 40320)
+(test-interpret-stack
+ '((fact-rec 9))
+ 362880)
+(test-interpret-stack
+ '((fact-rec 10))
+ 3628800)
+
+;; total-pushes = 32n - 16
+;; max-depth = 5n + 3
+
+;; Exercise 5.28. Modify the definition of the evaluator by changing eval-sequence as described in section 5.4.2 so that the evaluator is no longer tail-recursive. Rerun your experiments from exercises 5.26 and 5.27 to demonstrate that both versions of the factorial procedure now require space that grows linearly with their input.
blob - /dev/null
blob + 94aba7b93c286ee05eb0dbb577c715e2e9c35ba3 (mode 644)
--- /dev/null
+++ ex5-29.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (stack-statistics)
+ (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ ((eq? message 'stack-statistics)
+ (stack-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))
+ (list 'stack-statistics
+ (lambda () (stack 'stack-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-continue))
+ (goto (label eval-dispatch))
+
+ eval-continue
+ (assign unev (op stack-statistics))
+ (goto (label eval-loop))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(define (test-interpret-stack code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected)
+ (display (get-register-contents eceval 'unev))
+ (newline))
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; procedure definition / application
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; cond
+
+(test-interpret-stack
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret-stack
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)))
+ false)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)
+ (else 4)))
+ 4)
+
+;; let
+
+(test-interpret-stack
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret-stack
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret-stack
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret-stack
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
+
+;; Exercise 5.26. Use the monitored stack to explore the tail-recursive property of the evaluator (section 5.4.2). Start the evaluator and define the iterative factorial procedure from section 1.2.1:
+
+(test-interpret-stack
+ '((define (factorial n)
+ (define (iter product counter)
+ (if (> counter n)
+ product
+ (iter (* counter product)
+ (+ counter 1))))
+ (iter 1 1))
+ (factorial 1))
+ 1)
+(test-interpret-stack
+ '((factorial 2))
+ 2)
+(test-interpret-stack
+ '((factorial 3))
+ 6)
+(test-interpret-stack
+ '((factorial 4))
+ 24)
+(test-interpret-stack
+ '((factorial 5))
+ 120)
+(test-interpret-stack
+ '((factorial 6))
+ 720)
+(test-interpret-stack
+ '((factorial 7))
+ 5040)
+(test-interpret-stack
+ '((factorial 8))
+ 40320)
+(test-interpret-stack
+ '((factorial 9))
+ 362880)
+
+;; Run the procedure with some small values of n. Record the maximum stack depth and the number of pushes required to compute n! for each of these values.
+
+;; a. You will find that the maximum depth required to evaluate n! is independent of n. What is that depth?
+
+;; 10
+
+;; b. Determine from your data a formula in terms of n for the total number of push operations used in evaluating n! for any n > 1. Note that the number of operations used is a linear function of n and is thus determined by two constants.
+
+;; 35n + 29
+
+;; Exercise 5.27. For comparison with exercise 5.26, explore the behavior of the following procedure for computing factorials recursively:
+
+(test-interpret-stack
+ '((define (fact-rec n)
+ (if (= n 1)
+ 1
+ (* (fact-rec (- n 1)) n)))
+ (fact-rec 1))
+ 1)
+(test-interpret-stack
+ '((fact-rec 2))
+ 2)
+(test-interpret-stack
+ '((fact-rec 3))
+ 6)
+(test-interpret-stack
+ '((fact-rec 4))
+ 24)
+(test-interpret-stack
+ '((fact-rec 5))
+ 120)
+(test-interpret-stack
+ '((fact-rec 6))
+ 720)
+(test-interpret-stack
+ '((fact-rec 7))
+ 5040)
+(test-interpret-stack
+ '((fact-rec 8))
+ 40320)
+(test-interpret-stack
+ '((fact-rec 9))
+ 362880)
+(test-interpret-stack
+ '((fact-rec 10))
+ 3628800)
+
+;; total-pushes = 32n - 16
+;; max-depth = 5n + 3
+
+;; Exercise 5.29. Monitor the stack operations in the tree-recursive Fibonacci computation:
+
+(test-interpret-stack
+ '((define (fib n)
+ (if (< n 2)
+ n
+ (+ (fib (- n 1)) (fib (- n 2))))))
+ 'ok)
+(test-interpret-stack
+ '((fib 3))
+ 2)
+(test-interpret-stack
+ '((fib 4))
+ 3)
+(test-interpret-stack
+ '((fib 5))
+ 5)
+(test-interpret-stack
+ '((fib 6))
+ 8)
+(test-interpret-stack
+ '((fib 7))
+ 13)
+(test-interpret-stack
+ '((fib 8))
+ 21)
+(test-interpret-stack
+ '((fib 9))
+ 34)
+(test-interpret-stack
+ '((fib 10))
+ 55)
+(test-interpret-stack
+ '((fib 11))
+ 89)
+(test-interpret-stack
+ '((fib 12))
+ 144)
+(test-interpret-stack
+ '((fib 13))
+ 233)
+
+;; a. Give a formula in terms of n for the maximum depth of the stack required to compute Fib(n) for n > 2. Hint: In section 1.2.2 we argued that the space used by this process grows linearly with n.
+
+;; (total-pushes = 128 maximum-depth = 18)
+;; (total-pushes = 240 maximum-depth = 23)
+;; (total-pushes = 408 maximum-depth = 28)
+;; (total-pushes = 688 maximum-depth = 33)
+;; (total-pushes = 1136 maximum-depth = 38)
+;; (total-pushes = 1864 maximum-depth = 43)
+;; (total-pushes = 3040 maximum-depth = 48)
+;; (total-pushes = 4944 maximum-depth = 53)
+;; (total-pushes = 8024 maximum-depth = 58)
+;; (total-pushes = 13008 maximum-depth = 63)
+;; (total-pushes = 21072 maximum-depth = 68)
+
+;; max-depth = 5n + 13
+
+;; b. Give a formula for the total number of pushes used to compute Fib(n) for n > 2. You should find that the number of pushes (which correlates well with the time used) grows exponentially with n. Hint: Let S(n) be the number of pushes used in computing Fib(n). You should be able to argue that there is a formula that expresses S(n) in terms of S(n - 1), S(n - 2), and some fixed ``overhead'' constant k that is independent of n. Give the formula, and say what k is. Then show that S(n) can be expressed as a Fib(n + 1) + b and give the values of a and b.
+
+;; total pushes = S(n-2) + S(n-1) + 40
blob - /dev/null
blob + 4f21526a30177b2aed6eea54efe8e419378209c3 (mode 644)
--- /dev/null
+++ ex5-29.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (stack-statistics)
+ (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ ((eq? message 'stack-statistics)
+ (stack-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))
+ (list 'stack-statistics
+ (lambda () (stack 'stack-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-continue))
+ (goto (label eval-dispatch))
+
+ eval-continue
+ (assign unev (op stack-statistics))
+ (goto (label eval-loop))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(define (test-interpret-stack code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected)
+ (display (get-register-contents eceval 'unev))
+ (newline))
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; procedure definition / application
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; cond
+
+(test-interpret-stack
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret-stack
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)))
+ false)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)
+ (else 4)))
+ 4)
+
+;; let
+
+(test-interpret-stack
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret-stack
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret-stack
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret-stack
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
+
+;; Exercise 5.26. Use the monitored stack to explore the tail-recursive property of the evaluator (section 5.4.2). Start the evaluator and define the iterative factorial procedure from section 1.2.1:
+
+(test-interpret-stack
+ '((define (factorial n)
+ (define (iter product counter)
+ (if (> counter n)
+ product
+ (iter (* counter product)
+ (+ counter 1))))
+ (iter 1 1))
+ (factorial 1))
+ 1)
+(test-interpret-stack
+ '((factorial 2))
+ 2)
+(test-interpret-stack
+ '((factorial 3))
+ 6)
+(test-interpret-stack
+ '((factorial 4))
+ 24)
+(test-interpret-stack
+ '((factorial 5))
+ 120)
+(test-interpret-stack
+ '((factorial 6))
+ 720)
+(test-interpret-stack
+ '((factorial 7))
+ 5040)
+(test-interpret-stack
+ '((factorial 8))
+ 40320)
+(test-interpret-stack
+ '((factorial 9))
+ 362880)
+
+;; Run the procedure with some small values of n. Record the maximum stack depth and the number of pushes required to compute n! for each of these values.
+
+;; a. You will find that the maximum depth required to evaluate n! is independent of n. What is that depth?
+
+;; 10
+
+;; b. Determine from your data a formula in terms of n for the total number of push operations used in evaluating n! for any n > 1. Note that the number of operations used is a linear function of n and is thus determined by two constants.
+
+;; 35n + 29
+
+;; Exercise 5.27. For comparison with exercise 5.26, explore the behavior of the following procedure for computing factorials recursively:
+
+(test-interpret-stack
+ '((define (fact-rec n)
+ (if (= n 1)
+ 1
+ (* (fact-rec (- n 1)) n)))
+ (fact-rec 1))
+ 1)
+(test-interpret-stack
+ '((fact-rec 2))
+ 2)
+(test-interpret-stack
+ '((fact-rec 3))
+ 6)
+(test-interpret-stack
+ '((fact-rec 4))
+ 24)
+(test-interpret-stack
+ '((fact-rec 5))
+ 120)
+(test-interpret-stack
+ '((fact-rec 6))
+ 720)
+(test-interpret-stack
+ '((fact-rec 7))
+ 5040)
+(test-interpret-stack
+ '((fact-rec 8))
+ 40320)
+(test-interpret-stack
+ '((fact-rec 9))
+ 362880)
+(test-interpret-stack
+ '((fact-rec 10))
+ 3628800)
+
+;; total-pushes = 32n - 16
+;; max-depth = 5n + 3
+
+;; Exercise 5.28. Modify the definition of the evaluator by changing eval-sequence as described in section 5.4.2 so that the evaluator is no longer tail-recursive. Rerun your experiments from exercises 5.26 and 5.27 to demonstrate that both versions of the factorial procedure now require space that grows linearly with their input.
blob - /dev/null
blob + f9c89a04a74f3bd6935e7ef3521debbec5cae693 (mode 644)
--- /dev/null
+++ ex5-3.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (receive insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels))
+ (receive (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+;; (define (factorial n)
+;; (define (iter product counter)
+;; (if (> counter n)
+;; product
+;; (iter (* counter product)
+;; (+ counter 1))))
+;; (iter 1 1))
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+
+;; Exercise 5.3. Design a machine to compute square roots using Newton's method, as described in section 1.1.7:
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+;; Begin by assuming that good-enough? and improve operations are available as primitives. Then show how to expand these in terms of arithmetic operations. Describe each version of the sqrt machine design by drawing a data-path diagram and writing a controller definition in the register-machine language.
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
blob - /dev/null
blob + e89067e1427d83b3ac193c8c3dcabfcaaec58b85 (mode 644)
--- /dev/null
+++ ex5-31.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (stack-statistics)
+ (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ ((eq? message 'stack-statistics)
+ (stack-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))
+ (list 'stack-statistics
+ (lambda () (stack 'stack-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-continue))
+ (goto (label eval-dispatch))
+
+ eval-continue
+ (assign unev (op stack-statistics))
+ (goto (label eval-loop))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(define (test-interpret-stack code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected)
+ (display (get-register-contents eceval 'unev))
+ (newline))
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; procedure definition / application
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; cond
+
+(test-interpret-stack
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret-stack
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)))
+ false)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)
+ (else 4)))
+ 4)
+
+;; let
+
+(test-interpret-stack
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret-stack
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret-stack
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret-stack
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
+
+(test-interpret-stack
+ '((define (factorial n)
+ (define (iter product counter)
+ (if (> counter n)
+ product
+ (iter (* counter product)
+ (+ counter 1))))
+ (iter 1 1)))
+ 'ok)
+(test-interpret-stack
+ '((factorial 9))
+ 362880)
+
+(test-interpret-stack
+ '((define (fact-rec n)
+ (if (= n 1)
+ 1
+ (* (fact-rec (- n 1)) n))))
+ 'ok)
+(test-interpret-stack
+ '((fact-rec 10))
+ 3628800)
+
+(test-interpret-stack
+ '((define (fib n)
+ (if (< n 2)
+ n
+ (+ (fib (- n 1)) (fib (- n 2))))))
+ 'ok)
+(test-interpret-stack
+ '((fib 13))
+ 233)
+
+;; repeat 5 times
+
+(define (compile exp target linkage)
+ (cond ((self-evaluating? exp) (compile-self-evaluating exp target linkage))
+ ((quoted? exp) (compile-quoted exp target linkage))
+ ((variable? exp) (compile-variable exp target linkage))
+ ((lambda? exp) (compile-lambda exp target linkage))
+ ((begin? exp) (compile-sequence (begin-actions exp) target linkage))
+ ((if? exp) (compile-if exp target linkage))
+ ((cond? exp) (compile (cond->if exp) target linkage))
+ ((assignment? exp) (compile-assignment exp target linkage))
+ ((definition? exp) (compile-definition exp target linkage))
+ ((application? exp) (compile-application exp target linkage))
+ (else (error "Unknown expression type -- COMPILE" exp))))
+
+(define (make-instruction-sequence needs modifies statements)
+ (list needs modifies statements))
+(define (empty-instruction-sequence)
+ (make-instruction-sequence '() '() '()))
+
+(define (compile-linkage linkage)
+ (cond ((eq? linkage 'next) (empty-instruction-sequence))
+ ((eq? linkage 'return)
+ (make-instruction-sequence
+ '(continue) '()
+ '((goto (reg continue)))))
+ (else
+ (make-instruction-sequence
+ '() '()
+ `((goto (label ,linkage)))))))
+(define (end-with-linkage linkage instruction-sequence)
+ (preserving '(continue)
+ instruction-sequence
+ (compile-linkage linkage)))
+
+(define (compile-self-evaluating exp target linkage)
+ (end-with-linkage
+ linkage
+ (make-instruction-sequence
+ '() (list target)
+ `((assign ,target (const ,exp))))))
+(define (compile-quoted exp target linkage)
+ (end-with-linkage linkage
+ (make-instruction-sequence
+ '() (list target)
+ `((assign ,target (const ,(text-of-quotation exp)))))))
+(define (compile-variable exp target linkage)
+ (end-with-linkage linkage
+ (make-instruction-sequence
+ '(env) (list target)
+ `((assign ,target (op lookup-variable-value) (const ,exp) (reg env))))))
+(define (compile-assignment exp target linkage)
+ (let ((var (assignment-variable exp))
+ (val-code (compile (assignment-value exp) 'val 'next)))
+ (preserving '(continue env)
+ val-code
+ (end-with-linkage linkage
+ (make-instruction-sequence
+ '(val env) (list target)
+ `((perform (op set-variable-value!) (const ,var) (reg val) (reg env))
+ (assign ,target (const ok))))))))
+(define (compile-definition exp target linkage)
+ (let ((var (definition-variable exp))
+ (get-value-code (compile (definition-value exp) 'val 'next)))
+ (preserving '(continue env)
+ get-value-code
+ (end-with-linkage linkage
+ (make-instruction-sequence
+ '(val env) (list target)
+ `((perform (op define-variable!) (const ,var) (reg val) (reg env))
+ (assign ,target (const ok))))))))
+(define (compile-if exp target linkage)
+ (let* ((t-branch (make-label 't-branch))
+ (f-branch (make-label 'f-branch))
+ (after-if (make-label 'after-if))
+ (consequent-linkage (if (eq? linkage 'next) after-if linkage))
+ (p-code (compile (if-predicate exp) 'val 'next))
+ (c-code (compile (if-consequent exp) target consequent-linkage))
+ (a-code (compile (if-alternative exp) target linkage)))
+ (preserving '(continue env)
+ p-code
+ (append-instruction-sequences
+ (make-instruction-sequence
+ '(val) '()
+ `((test (op false?) (reg val))
+ (branch (label ,f-branch))))
+ (parallel-instruction-sequences
+ (append-instruction-sequences t-branch c-code)
+ (append-instruction-sequences f-branch a-code))
+ after-if))
+(define (compile-sequence seq target linkage)
+ (if (last-exp? seq)
+ (compile (first-exp seq) target linkage)
+ (preserving '(env continue)
+ (compile (first-exp seq) target 'next)
+ (compile-sequence (rest-exps seq) target linkage))))
+(define (compile-lambda exp target linkage)
+ (let* ((after-lambda (make-label 'after-lambda))
+ (proc-entry (make-label 'proc-entry))
+ (lambda-linkage (if (eq? linkage 'next) after-lambda linkage)))
+ (append-instruction-sequence
+ (tack-on-instruction-sequence
+ (end-with-linkage lambda-linkage
+ (make-instruction-sequence
+ '(env) (list target)
+ `((assign ,target (op make-compiled-procedure) (label ,proc-entry) (reg env)))))
+ (compile-lambda-body exp proc-entry))
+ after-lambda)))
+(define (compile-lambda-body exp proc-entry)
+
+
+(compile-application exp target linkage)
+
+(define label-counter 0)
+(define (new-label-number)
+ (set! label-counter (+ label-counter 1))
+ label-counter)
+(define (make-label name)
+ (string->symbol
+ (string-append
+ (symbol->string name)
+ (number->string (new-label-number)))))
+
+(define (preserving regs seq1 seq2)
+ ...)
+(define (append-instruction-sequences . seq)
+ ...)
+tack-on-instruction-sequence
+parallel-instruction-sequence
blob - /dev/null
blob + 94aba7b93c286ee05eb0dbb577c715e2e9c35ba3 (mode 644)
--- /dev/null
+++ ex5-31.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (stack-statistics)
+ (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ ((eq? message 'stack-statistics)
+ (stack-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))
+ (list 'stack-statistics
+ (lambda () (stack 'stack-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-stack-pair reg-name contents)
+ (cons reg-name contents))
+(define (stack-pair-reg-name pair)
+ (car pair))
+(define (stack-pair-val pair)
+ (cdr pair))
+(define (make-save inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (push stack (make-stack-pair reg-name (get-contents reg)))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let* ((reg-name (stack-inst-reg-name inst))
+ (reg (get-register machine reg-name)))
+ (lambda ()
+ (let* ((stack-pair (pop stack))
+ (stack-reg-name (stack-pair-reg-name stack-pair))
+ (stack-val (stack-pair-val stack-pair)))
+ (if (eq? stack-reg-name reg-name)
+ (begin (set-contents! reg stack-val)
+ (advance-pc pc))
+ (error "Stack/register mismatch -- Save/Restore: "
+ stack-reg-name reg-name))))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ ;; (if (label-exp? e)
+ ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ ;; exp)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+(define fact-rec
+ (make-machine
+ '(n val continue)
+ `((= ,=) (- ,-) (* ,*))
+ '((assign continue (label fact-done)) ; set up final return address
+ fact-loop
+ (test (op =) (reg n) (const 1))
+ (branch (label base-case))
+ ;; Set up for the recursive call by saving n and continue.
+ ;; Set up continue so that the computation will continue
+ ;; at after-fact when the subroutine returns.
+ (save continue)
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (assign continue (label after-fact))
+ (goto (label fact-loop))
+ after-fact
+ (restore n)
+ (restore continue)
+ (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
+ (goto (reg continue)) ; return to caller
+ base-case
+ (assign val (const 1)) ; base case: 1! = 1
+ (goto (reg continue)) ; return to caller
+ fact-done
+ (perform (op print-stack-statistics)))))
+
+(define count-leaves-rec
+ (make-machine
+ '(tree val continue)
+ `((pair? ,pair?)
+ (null? ,null?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign continue (label count-leaves-done))
+ count-leaves
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (const 1))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign tree (op car) (reg tree))
+ (assign continue (label left-tree-done))
+ (goto (label count-leaves))
+ left-tree-done
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (assign continue (label right-tree-done))
+ (save val)
+ (goto (label count-leaves))
+ right-tree-done
+ (assign tree (reg val))
+ (restore val)
+ (assign val (op +) (reg tree) (reg val))
+ (restore continue)
+ (goto (reg continue))
+ null-tree
+ (assign val (const 0))
+ (goto (reg continue))
+ count-leaves-done)))
+
+(set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
+(start count-leaves-rec)
+(test-case (get-register-contents count-leaves-rec 'val)
+ 11)
+
+(define count-leaves-iter
+ (make-machine
+ '(tree n val continue)
+ `((null? ,null?)
+ (pair? ,pair?)
+ (car ,car)
+ (cdr ,cdr)
+ (+ ,+))
+ '((assign n (const 0))
+ (assign continue (label count-iter-done))
+ count-iter
+ (test (op null?) (reg tree))
+ (branch (label null-tree))
+ (test (op pair?) (reg tree))
+ (branch (label pair-tree))
+ (assign val (op +) (reg n) (const 1))
+ (goto (reg continue))
+ null-tree
+ (assign val (reg n))
+ (goto (reg continue))
+ pair-tree
+ (save continue)
+ (save tree)
+ (assign continue (label left-tree-done))
+ (assign tree (op car) (reg tree))
+ (goto (label count-iter))
+ left-tree-done
+ (assign n (reg val))
+ (restore tree)
+ (assign tree (op cdr) (reg tree))
+ (restore continue)
+ (goto (label count-iter))
+ count-iter-done)))
+
+(set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 12)
+(set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
+(start count-leaves-iter)
+(test-case (get-register-contents count-leaves-iter 'val)
+ 7)
+
+(define (append x y)
+ (if (null? x)
+ y
+ (cons (car x) (append (cdr x) y))))
+
+(define append-machine
+ (make-machine
+ '(x y carx val continue)
+ `((cons ,cons)
+ (car ,car)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((assign continue (label append-done))
+ append
+ (test (op null?) (reg x))
+ (branch (label null-x))
+ (assign carx (op car) (reg x))
+ (save carx)
+ (assign x (op cdr) (reg x))
+ (save continue)
+ (assign continue (label after-null-x))
+ (goto (label append))
+ null-x
+ (assign val (reg y))
+ (goto (reg continue))
+ after-null-x
+ (restore continue)
+ (restore carx)
+ (assign val (op cons) (reg carx) (reg val))
+ (goto (reg continue))
+ append-done)))
+(set-register-contents! append-machine 'x '(a (b c) ((d) e)))
+(set-register-contents! append-machine 'y '(((f g) (h)) i))
+(start append-machine)
+(test-case (get-register-contents append-machine 'val)
+ '(a (b c) ((d) e) ((f g) (h)) i))
+
+(define append!-machine
+ (make-machine
+ '(x y cdrx)
+ `((set-cdr! ,set-cdr!)
+ (cdr ,cdr)
+ (null? ,null?))
+ '((save x)
+ (assign cdrx (op cdr) (reg x))
+ last-pair
+ (test (op null?) (reg cdrx))
+ (branch (label set-cdr!))
+ (assign x (reg cdrx))
+ (assign cdrx (op cdr) (reg x))
+ (goto (label last-pair))
+ set-cdr!
+ (perform (op set-cdr!) (reg x) (reg y))
+ (restore x)
+ append!-done)))
+(define (append! x y)
+ (set-cdr! (last-pair x) y)
+ x)
+
+(define (last-pair x)
+ (if (null? (cdr x))
+ x
+ (last-pair (cdr x))))
+
+(set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
+(set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
+(start append!-machine)
+(test-case (get-register-contents append!-machine 'x)
+ '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
+
+;; procedures from metacircular evaluator
+
+;; REPL
+
+(define (prompt-for-input string)
+ (newline) (newline) (display string) (newline))
+(define (announce-output string)
+ (newline) (display string) (newline))
+(define (user-print object)
+ (if (compound-procedure? object)
+ (display (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+;; self-evaluating/variables/quoted
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+(define (variable? exp) (symbol? exp))
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+;; assignments/definitions
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp) ; formal parameters
+ (cddr exp)))) ; body
+
+;; if
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+;; cond
+(define (cond? exp) (tagged-list? exp 'cond))
+(define (cond-clauses exp) (cdr exp))
+(define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest))))))
+
+
+;; lambda
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+;; let
+
+(define (make-let vars vals body)
+ (cons 'let
+ (cons (map list vars vals)
+ body)))
+(define (let? exp)
+ (and (tagged-list? exp 'let)
+ (not (symbol? (cadr exp)))))
+(define (let-vars exp)
+ (map car (cadr exp)))
+(define (let-vals exp)
+ (map cadr (cadr exp)))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (make-application (make-lambda (let-vars exp) (let-body exp))
+ (let-vals exp)))
+(define (make-application op args)
+ (cons op args))
+
+;; begin
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+(define (make-begin seq) (cons 'begin seq))
+
+;; applications
+
+(define (application? exp) (pair? exp))
+(define (operator exp) (car exp))
+(define (operands exp) (cdr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (empty-arglist) '())
+(define (adjoin-arg arg arglist)
+ (append arglist (list arg)))
+(define (last-operand? ops)
+ (null? (cdr ops)))
+
+;; true/false
+
+(define (true? x)
+ (not (eq? x false)))
+(define (false? x)
+ (eq? x false))
+
+;; compound procedures
+
+(define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (caddr p))
+(define (procedure-environment p) (cadddr p))
+
+;; environment procedures/data structures
+
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+(define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied" vars vals)
+ (error "Too few arguments supplied" vars vals))))
+(define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (let ((val (car vals)))
+ (if (eq? val '*unassigned*)
+ (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
+ val)))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (set-variable-value! var val env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+(define (define-variable! var val env)
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame! var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+(define (primitive-implementation proc) (cadr proc))
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'caar caar)
+ (list 'cadr cadr)
+ (list 'cddr cddr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '* *)
+ (list '/ /)
+ (list '+ +)
+ (list '- -)
+ (list '= =)
+ (list '< <)
+ (list '> >)
+ (list '<= <=)
+ (list '>= >=)
+ (list 'remainder remainder)
+ (list 'eq? eq?)
+ (list 'equal? equal?)
+ (list 'display display)))
+(define (primitive-procedure-names)
+ (map car
+ primitive-procedures))
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+(define the-global-environment (setup-environment))
+(define (get-global-environment)
+ the-global-environment)
+
+;; Explicit Control Evaluator Machine
+
+(define eceval-operations
+ `((prompt-for-input ,prompt-for-input)
+ (read ,read)
+ (get-global-environment ,get-global-environment)
+ (announce-output ,announce-output)
+ (user-print ,user-print)
+ (self-evaluating? ,self-evaluating?)
+ (variable? ,variable?)
+ (quoted? ,quoted?)
+ (assignment? ,assignment?)
+ (definition? ,definition?)
+ (if? ,if?)
+ (cond? ,cond?)
+ (cond->if ,cond->if)
+ (lambda? ,lambda?)
+ (begin? ,begin?)
+ (application? ,application?)
+ (lookup-variable-value ,lookup-variable-value)
+ (text-of-quotation ,text-of-quotation)
+ (lambda-parameters ,lambda-parameters)
+ (lambda-body ,lambda-body)
+ (make-procedure ,make-procedure)
+ (let->combination ,let->combination)
+ (let? ,let?)
+ (operands ,operands)
+ (operator ,operator)
+ (empty-arglist ,empty-arglist)
+ (no-operands? ,no-operands?)
+ (first-operand ,first-operand)
+ (rest-operands ,rest-operands)
+ (last-operand? ,last-operand?)
+ (adjoin-arg ,adjoin-arg)
+ (procedure-parameters ,procedure-parameters)
+ (procedure-environment ,procedure-environment)
+ (extend-environment ,extend-environment)
+ (procedure-body ,procedure-body)
+ (begin-actions ,begin-actions)
+ (first-exp ,first-exp)
+ (last-exp? ,last-exp?)
+ (rest-exps ,rest-exps)
+ (true? ,true?)
+ (if-predicate ,if-predicate)
+ (if-alternative ,if-alternative)
+ (if-consequent ,if-consequent)
+ (assignment-variable ,assignment-variable)
+ (assignment-value ,assignment-value)
+ (set-variable-value! ,set-variable-value!)
+ (definition-variable ,definition-variable)
+ (definition-value ,definition-value)
+ (define-variable! ,define-variable!)
+ (primitive-procedure? ,primitive-procedure?)
+ (apply-primitive-procedure ,apply-primitive-procedure)
+ (compound-procedure? ,compound-procedure?)
+ (user-print ,user-print)
+ (null? ,null?)))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev code)
+ eceval-operations
+ '(
+ eval-loop
+ (test (op null?) (reg code))
+ (branch (label eval-done))
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign exp (op first-exp) (reg code))
+ (assign code (op rest-exps) (reg code))
+ (assign continue (label eval-continue))
+ (goto (label eval-dispatch))
+
+ eval-continue
+ (assign unev (op stack-statistics))
+ (goto (label eval-loop))
+
+ read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+ print-result
+ (perform (op print-stack-statistics)); added instruction
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op cond?) (reg exp))
+ (branch (label ev-cond))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op let?) (reg exp))
+ (branch (label ev-let))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+ ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+ ev-let
+ (assign exp (op let->combination) (reg exp))
+ (goto (label eval-dispatch))
+ ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ ev-appl-did-operator
+ (restore unev) ; the operands
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val)) ; the operator
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+ apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+ (goto (label unknown-procedure-type))
+ primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+ compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+ ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+ ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+ ev-if
+ (save exp) ; save expression for later
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch)) ; evaluate the predicate
+ ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+
+ ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-cond
+ (assign exp (op cond->if) (reg exp))
+ (goto (label eval-dispatch))
+
+ ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch)) ; evaluate the assignment value
+ ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev) ; save variable for later
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch)) ; evaluate the definition value
+ ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+ unknown-procedure-type
+ (restore continue) ; clean up stack (from apply-dispatch)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+ signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+ eval-done)))
+
+;; test suite
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (factorial n)
+;; (if (= n 1)
+;; 1
+;; (* n (factorial (- n 1)))))
+;; (factorial 8)))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 40320)
+
+
+;; (set-register-contents!
+;; eceval
+;; 'code
+;; '((define (cons x y)
+;; (lambda (m) (m x y)))
+;; (define (car z)
+;; (z (lambda (p q) p)))
+;; (define (cdr z)
+;; (z (lambda (p q) q)))
+;; (define pair (cons 3 2))
+;; (+ (car pair) (cdr pair))))
+;; (start eceval)
+;; (test-case (get-register-contents eceval 'val)
+;; 5)
+
+(define (test-interpret code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected))
+
+(define (test-interpret-stack code expected)
+ (set-register-contents! eceval 'code code)
+ (start eceval)
+ (test-case (get-register-contents eceval 'val) expected)
+ (display (get-register-contents eceval 'unev))
+ (newline))
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; procedure definition / application
+
+(test-interpret-stack
+ '((define (factorial n)
+ (if (= n 1)
+ 1
+ (* n (factorial (- n 1)))))
+ (factorial 8))
+ 40320)
+(test-interpret-stack
+ '((define (cons x y)
+ (lambda (m) (m x y)))
+ (define (car z)
+ (z (lambda (p q) p)))
+ (define (cdr z)
+ (z (lambda (p q) q)))
+ (define pair (cons 3 2))
+ (+ (car pair) (cdr pair)))
+ 5)
+
+;; cond
+
+(test-interpret-stack
+ '((define x -25)
+ (cond ((= x -2) 'x=-2)
+ ((= x -25) 'x=-25)
+ (else 'failed)))
+ 'x=-25)
+(test-interpret-stack
+ '((cond ((= 2 4) 3)
+ ((= 2 (factorial 3)) true)
+ (((lambda (result) result) true) 5)))
+ 5)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)))
+ false)
+(test-interpret-stack
+ '((cond (((lambda (result) result) false) 5)
+ ((car (cons false true)) 3)
+ (else 4)))
+ 4)
+
+;; let
+
+(test-interpret-stack
+ '((let ((x 4) (y 7))
+ (+ x y (* x y))))
+ (+ 4 7 (* 4 7)))
+(test-interpret-stack
+ '((let ((x 3)
+ (y 5))
+ (+ x y)))
+ 8)
+(test-interpret-stack
+ '((let ((x 3)
+ (y 2))
+ (+ (let ((x (+ y 2))
+ (y x))
+ (* x y))
+ x y)))
+ (+ (* 4 3) 3 2))
+(test-interpret-stack
+ '((let ((x 6)
+ (y (let ((x 2))
+ (+ x 3)))
+ (z (let ((a (* 3 2)))
+ (+ a 3))))
+ (+ x y z)))
+ (+ 6 5 9))
+
+;; Exercise 5.26. Use the monitored stack to explore the tail-recursive property of the evaluator (section 5.4.2). Start the evaluator and define the iterative factorial procedure from section 1.2.1:
+
+(test-interpret-stack
+ '((define (factorial n)
+ (define (iter product counter)
+ (if (> counter n)
+ product
+ (iter (* counter product)
+ (+ counter 1))))
+ (iter 1 1))
+ (factorial 1))
+ 1)
+(test-interpret-stack
+ '((factorial 2))
+ 2)
+(test-interpret-stack
+ '((factorial 3))
+ 6)
+(test-interpret-stack
+ '((factorial 4))
+ 24)
+(test-interpret-stack
+ '((factorial 5))
+ 120)
+(test-interpret-stack
+ '((factorial 6))
+ 720)
+(test-interpret-stack
+ '((factorial 7))
+ 5040)
+(test-interpret-stack
+ '((factorial 8))
+ 40320)
+(test-interpret-stack
+ '((factorial 9))
+ 362880)
+
+;; Run the procedure with some small values of n. Record the maximum stack depth and the number of pushes required to compute n! for each of these values.
+
+;; a. You will find that the maximum depth required to evaluate n! is independent of n. What is that depth?
+
+;; 10
+
+;; b. Determine from your data a formula in terms of n for the total number of push operations used in evaluating n! for any n > 1. Note that the number of operations used is a linear function of n and is thus determined by two constants.
+
+;; 35n + 29
+
+;; Exercise 5.27. For comparison with exercise 5.26, explore the behavior of the following procedure for computing factorials recursively:
+
+(test-interpret-stack
+ '((define (fact-rec n)
+ (if (= n 1)
+ 1
+ (* (fact-rec (- n 1)) n)))
+ (fact-rec 1))
+ 1)
+(test-interpret-stack
+ '((fact-rec 2))
+ 2)
+(test-interpret-stack
+ '((fact-rec 3))
+ 6)
+(test-interpret-stack
+ '((fact-rec 4))
+ 24)
+(test-interpret-stack
+ '((fact-rec 5))
+ 120)
+(test-interpret-stack
+ '((fact-rec 6))
+ 720)
+(test-interpret-stack
+ '((fact-rec 7))
+ 5040)
+(test-interpret-stack
+ '((fact-rec 8))
+ 40320)
+(test-interpret-stack
+ '((fact-rec 9))
+ 362880)
+(test-interpret-stack
+ '((fact-rec 10))
+ 3628800)
+
+;; total-pushes = 32n - 16
+;; max-depth = 5n + 3
+
+;; Exercise 5.29. Monitor the stack operations in the tree-recursive Fibonacci computation:
+
+(test-interpret-stack
+ '((define (fib n)
+ (if (< n 2)
+ n
+ (+ (fib (- n 1)) (fib (- n 2))))))
+ 'ok)
+(test-interpret-stack
+ '((fib 3))
+ 2)
+(test-interpret-stack
+ '((fib 4))
+ 3)
+(test-interpret-stack
+ '((fib 5))
+ 5)
+(test-interpret-stack
+ '((fib 6))
+ 8)
+(test-interpret-stack
+ '((fib 7))
+ 13)
+(test-interpret-stack
+ '((fib 8))
+ 21)
+(test-interpret-stack
+ '((fib 9))
+ 34)
+(test-interpret-stack
+ '((fib 10))
+ 55)
+(test-interpret-stack
+ '((fib 11))
+ 89)
+(test-interpret-stack
+ '((fib 12))
+ 144)
+(test-interpret-stack
+ '((fib 13))
+ 233)
+
+;; a. Give a formula in terms of n for the maximum depth of the stack required to compute Fib(n) for n > 2. Hint: In section 1.2.2 we argued that the space used by this process grows linearly with n.
+
+;; (total-pushes = 128 maximum-depth = 18)
+;; (total-pushes = 240 maximum-depth = 23)
+;; (total-pushes = 408 maximum-depth = 28)
+;; (total-pushes = 688 maximum-depth = 33)
+;; (total-pushes = 1136 maximum-depth = 38)
+;; (total-pushes = 1864 maximum-depth = 43)
+;; (total-pushes = 3040 maximum-depth = 48)
+;; (total-pushes = 4944 maximum-depth = 53)
+;; (total-pushes = 8024 maximum-depth = 58)
+;; (total-pushes = 13008 maximum-depth = 63)
+;; (total-pushes = 21072 maximum-depth = 68)
+
+;; max-depth = 5n + 13
+
+;; b. Give a formula for the total number of pushes used to compute Fib(n) for n > 2. You should find that the number of pushes (which correlates well with the time used) grows exponentially with n. Hint: Let S(n) be the number of pushes used in computing Fib(n). You should be able to argue that there is a formula that expresses S(n) in terms of S(n - 1), S(n - 2), and some fixed ``overhead'' constant k that is independent of n. Give the formula, and say what k is. Then show that S(n) can be expressed as a Fib(n + 1) + b and give the values of a and b.
+
+;; total pushes = S(n-2) + S(n-1) + 40
blob - /dev/null
blob + 770a944f13aa4c59d74c461a0e29dae2f6ece99f (mode 644)
--- /dev/null
+++ ex5-4.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (receive insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels))
+ (receive (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+;; (define (factorial n)
+;; (define (iter product counter)
+;; (if (> counter n)
+;; product
+;; (iter (* counter product)
+;; (+ counter 1))))
+;; (iter 1 1))
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+
+;; Exercise 5.3. Design a machine to compute square roots using Newton's method, as described in section 1.1.7:
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+;; Begin by assuming that good-enough? and improve operations are available as primitives. Then show how to expand these in terms of arithmetic operations. Describe each version of the sqrt machine design by drawing a data-path diagram and writing a controller definition in the register-machine language.
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+ ;; Exercise 5.4. Specify register machines that implement each of the following procedures. For each machine, write a controller instruction sequence and draw a diagram showing the data paths.
+
+;; a. Recursive exponentiation:
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+
+;; b. Iterative exponentiation:
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
blob - /dev/null
blob + 7b6096eca6d46c04e696c8aa56b2c54f938a5a95 (mode 644)
--- /dev/null
+++ ex5-4.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (receive insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels))
+ (receive (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+;; (define (factorial n)
+;; (define (iter product counter)
+;; (if (> counter n)
+;; product
+;; (iter (* counter product)
+;; (+ counter 1))))
+;; (iter 1 1))
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+
+;; Exercise 5.3. Design a machine to compute square roots using Newton's method, as described in section 1.1.7:
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+;; Begin by assuming that good-enough? and improve operations are available as primitives. Then show how to expand these in terms of arithmetic operations. Describe each version of the sqrt machine design by drawing a data-path diagram and writing a controller definition in the register-machine language.
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+ ;; Exercise 5.4. Specify register machines that implement each of the following procedures. For each machine, write a controller instruction sequence and draw a diagram showing the data paths.
+
+;; a. Recursive exponentiation:
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '(expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+
+ base-case
+ (assign )
+
+
+;; b. Iterative exponentiation:
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
blob - /dev/null
blob + d6176724aad002fbf64a66a88a3bc02e4ed47509 (mode 644)
--- /dev/null
+++ ex5-5.scm
+(make-machine <regs> <ops> <controller>)
+(start <machine>)
+(set-register-contents! <machine> <reg> <value>)
+(get-register-contents <machine> <reg>)
+
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (val) (set! contents val)))
+ (else
+ (error "Unknown request -- REGISTER"
+ message))))
+ dispatch))
+
+(define (get-contents reg)
+ (reg 'get))
+(define (set-contents! reg val)
+ ((reg 'set) val))
+
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (current-depth 0)
+ (max-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ number-pushes 1))
+ (set! current-depth (+ current-depth 1))
+ (set! max-depth (max max-depth current-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! current-depth 0)
+ (set! max-depth 0))
+ (define (print-statistics)
+ `(total-pushes = ,number-pushes
+ max-depth = ,max-depth))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics) (print-statistics))
+ (else
+ (error "Unknown request -- STACK"
+ message))))
+ dispatch))
+(define (push stack val)
+ ((stack 'push) val))
+(define (pop stack)
+ (stack 'pop))
+
+(define (make-machine regs ops controller)
+ (let ((machine (make-new-machine)))
+ (for-each
+ (lambda (reg)
+ ((machine 'allocate-register) reg))
+ regs)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller machine))
+ machine))
+
+(define (make-new-machine)
+ (let* ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '())
+ (register-table
+ `((pc ,pc)
+ (flag ,flag)))
+ (the-ops
+ `((initialize
+ ,(lambda () (stack 'initialize)))
+ (print-statistics
+ ,(lambda () (stack 'print-statistics))))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin ((instruction-proc (car insts)))
+ (execute)))))
+ (define (allocate-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))))
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Undefined register: " name))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)))
+ dispatch))
+
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-proc inst)
+ (cdr inst))
+(define (instruction-text inst)
+ (car inst))
+(define (set-instruction-proc! inst proc)
+ (set-cdr! inst proc))
+
+(define (start machine)
+ (machine 'start))
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (set-register-contents! machine reg val)
+ (set-contents! (get-register machine reg) val)
+ 'done)
+(define (get-register-contents machine reg)
+ (get-contents (get-register machine reg)))
+
+(define (assemble controller-text machine)
+ (extract-labels
+ controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels
+ (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst insts) labels))
+ (receive
+ (cons (make-instruction next-inst) insts)
+ labels)))))))
+
+(define (extract-labels text)
+ (if (null? text)
+ (cons '() '())
+ (let* ((result (extract-labels (cdr text)))
+ (insts (car result))
+ (labels (cdr result))
+ (next-inst (car text)))
+ (if (symbol? next-inst)
+ (cons insts
+ (cons (make-label-entry next-inst insts)
+ labels))
+ (cons (cons (make-instruction next-inst) insts)
+ labels)))))
+(define (assemble controller machine)
+ (let* ((result (extract-labels controller))
+ (insts (car result))
+ (labels (cdr result)))
+ (update-insts! insts labels machine)
+ insts))
+
+(define (update-insts! insts labels machine)
+ (let* ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+
+(define (make-execution-procedure text labels machine
+ pc stack flag ops)
+ (cond ((eq? (car text) 'assign)
+ (make-assign
+ text machine labels ops pc))
+ ((eq? (car text) 'test)
+ (make-test
+ text machine labels ops pc))
+ ((eq? (car text) 'branch)
+ (make-branch
+ text machine labels flag pc))
+ ((eq? (car text) 'goto)
+ (make-goto
+ text machine labels pc))
+ ((eq? (car text) 'perform)
+ (make-perform
+ text machine labels ops pc))
+ ((eq? (car text) 'save)
+ (make-save
+ text machine stack pc))
+ ((eq? (car text) 'restore)
+ (make-restore
+ text machine stack pc))
+ (else
+ (error "Unknown instruction type -- ASSEMBLE"
+ text))))
+(define (make-assign inst machine labels ops pc)
+ (let* ((reg (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-reg-value inst))
+ (value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels ops)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda ()
+ (set-contents! reg (value-proc))
+ (advance-pc pc))))
+(define (assign-reg-name inst)
+ (cadr inst))
+(define (assign-reg-value inst)
+ (cddr inst))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels ops pc)
+ (let* ((test (test-cond inst)))
+ (if (operation-exp? test)
+ (let ((test-proc (make-operation-exp
+ test machine labels ops)))
+ (lambda ()
+ (set-contents! flag (test-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE"
+ inst))))
+(define (test-cond exp)
+ (cdr exp))
+(define (make-branch text machine labels flag pc)
+ (let ((dest (branch-dest text)))
+ (if (label-exp? dest)
+ (let ((insts (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE"
+ text))))
+(define (branch-dest exp)
+ (cadr exp))
+(define (make-goto text machine labels pc)
+ (let ((dest (goto-dest text)))
+ (cond ((register-exp? dest)
+ (let ((reg (get-register machine (register-exp-name dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ ((label-exp? dest)
+ (let ((insts (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (set-contents! pc insts))))
+ (else
+ (error "Bad GOTO instruction -- ASSEMBLE"
+ text)))))
+(define (goto-dest exp)
+ (cadr exp))
+(define (make-perform text machine labels ops pc)
+ (let ((action (perform-action text)))
+ (if (operation-exp? action)
+ (let ((action-proc (make-operation-exp
+ action machine labels ops)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE"
+ text))))
+(define (perform-action exp)
+ (cdr exp))
+(define (make-save text machine stack pc)
+ (let ((reg (get-register machine (stack-inst-reg text))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (stack-inst-reg exp)
+ (cadr exp))
+(define (make-restore text machine stack pc)
+ (let ((reg (get-register machine (stack-inst-reg text))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+
+(define (make-primitive-exp exp machine labels)
+ (cond ((register-exp? exp)
+ (let ((reg (get-register machine (register-exp-name exp))))
+ (lambda ()
+ (get-contents reg))))
+ ((const-exp? exp)
+ (let ((val (const-exp-value exp)))
+ (lambda () val)))
+ ((label-exp? exp)
+ (let ((insts (lookup-label labels (label-exp-label exp))))
+ (lambda () insts)))
+ (else
+ "Unknown expression type -- ASSEMBLE"
+ exp)))
+(define (register-exp? exp)
+ (tagged-list? exp 'reg))
+(define (register-exp-name exp)
+ (cadr exp))
+(define (const-exp? exp)
+ (tagged-list? exp 'const))
+(define (const-exp-value exp)
+ (cadr exp))
+(define (label-exp? exp)
+ (tagged-list? exp 'label))
+(define (label-exp-label exp)
+ (cadr exp))
+(define (make-operation-exp exp machine labels ops)
+ (let* ((proc (lookup-prim (operation-exp-op exp) ops))
+ (aprocs
+ (map (lambda (e)
+ (make-primitive-exp
+ e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply proc (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op))))
+(define (operation-exp-op exp)
+ (cadr (car exp)))
+(define (operation-exp-operands exp)
+ (cdr exp))
+(define (lookup-prim symbol ops)
+ (let ((val (assoc symbol ops)))
+ (if val
+ (cadr val)
+ (error "Undefined operation -- ASSEMBLE"
+ symbol))))
+(define (make-label-entry label insts)
+ (cons label insts))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE"
+ label-name))))
blob - /dev/null
blob + 32a23576c9e12cffc3581ef3d13b87f6a8acc3dd (mode 644)
--- /dev/null
+++ ex5-5.scm~
+(make-machine <regs> <ops> <controller>)
+(start <machine>)
+(set-register-contents! <machine> <reg> <value>)
+(get-register-contents <machine> <reg>)
+
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (val) (set! contents val)))
+ (else
+ (error "Unknown request -- REGISTER"
+ message))))
+ dispatch))
+
+(define (get-contents reg)
+ (reg 'get))
+(define (set-contents! reg val)
+ ((reg 'set) val))
+
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (current-depth 0)
+ (max-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ number-pushes 1))
+ (set! current-depth (+ current-depth 1))
+ (set! max-depth (max max-depth current-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! current-depth 0)
+ (set! max-depth 0))
+ (define (print-statistics)
+ `(total-pushes = ,number-pushes
+ max-depth = ,max-depth))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics) (print-statistics))
+ (else
+ (error "Unknown request -- STACK"
+ message))))
+ dispatch))
+(define (push stack val)
+ ((stack 'push) val))
+(define (pop stack)
+ (stack 'pop))
+
+(define (make-machine regs ops controller)
+ (let ((machine (make-new-machine)))
+ (for-each
+ (lambda (reg)
+ ((machine 'allocate-register) reg))
+ regs)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller machine))
+ machine))
+
+(define (make-new-machine)
+ (let* ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '())
+ (register-table
+ `((pc ,pc)
+ (flag ,flag)))
+ (the-ops
+ `((initialize
+ ,(lambda () (stack 'initialize)))
+ (print-statistics
+ ,(lambda () (stack 'print-statistics))))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin ((instruction-proc (car insts)))
+ (execute)))))
+ (define (allocate-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))))
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Undefined register: " name))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)))
+ dispatch))
+
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-proc inst)
+ (cdr inst))
+(define (instruction-text inst)
+ (car inst))
+(define (set-instruction-proc! inst proc)
+ (set-cdr! inst proc))
+
+(define (start machine)
+ (machine 'start))
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (set-register-contents! machine reg val)
+ (set-contents! (get-register machine reg) val)
+ 'done)
+(define (get-register-contents machine reg)
+ (get-contents (get-register machine reg)))
+
+(define (assemble controller-text machine)
+ (extract-labels
+ controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels
+ (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst insts) labels))
+ (receive
+ (cons (make-instruction next-inst) insts)
+ labels)))))))
+(define
+(define (update-insts! insts labels machine)
+ )
+
+(define (make-label-entry label insts)
+ (cons label insts))
+(define (lookup labels label-name)
+ ...)
blob - /dev/null
blob + 770a944f13aa4c59d74c461a0e29dae2f6ece99f (mode 644)
--- /dev/null
+++ ex5-6.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (receive insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels))
+ (receive (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+;; (define (factorial n)
+;; (define (iter product counter)
+;; (if (> counter n)
+;; product
+;; (iter (* counter product)
+;; (+ counter 1))))
+;; (iter 1 1))
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+
+;; Exercise 5.3. Design a machine to compute square roots using Newton's method, as described in section 1.1.7:
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+;; Begin by assuming that good-enough? and improve operations are available as primitives. Then show how to expand these in terms of arithmetic operations. Describe each version of the sqrt machine design by drawing a data-path diagram and writing a controller definition in the register-machine language.
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+ ;; Exercise 5.4. Specify register machines that implement each of the following procedures. For each machine, write a controller instruction sequence and draw a diagram showing the data paths.
+
+;; a. Recursive exponentiation:
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+
+;; b. Iterative exponentiation:
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
blob - /dev/null
blob + e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 (mode 644)
blob - /dev/null
blob + 35ae826db59f4829700a94fe5861d8891baa628e (mode 644)
--- /dev/null
+++ ex5-8.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; Exercise 5.8. The following register-machine code is ambiguous, because the label here is defined more than once:
+
+(define amb-machine
+ (make-machine
+ '(a)
+ '()
+ '(start
+ (goto (label here))
+ here
+ (assign a (const 3))
+ (goto (label there))
+ here
+ (assign a (const 4))
+ (goto (label there))
+ there)))
+
+;; With the simulator as written, what will the contents of register a be when control reaches there? Modify the extract-labels procedure so that the assembler will signal an error if the same label name is used to indicate two different locations.
+
+(start amb-machine)
+(test-case (get-register-contents amb-machine 'a)
+ 3)
+;; extract-labels builds insts/labels from the very last instruction to the first instruction and conses them in that order so that the insts/labels are in the same order as in the instruction
+;; since lookup-label uses assoc, the labels will also be accessed in the same order as the instruction sequence. Therefore, the (goto (label here)) will branch to the first here label and not the second one
+
blob - /dev/null
blob + 770a944f13aa4c59d74c461a0e29dae2f6ece99f (mode 644)
--- /dev/null
+++ ex5-8.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (receive insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels))
+ (receive (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+;; (define (factorial n)
+;; (define (iter product counter)
+;; (if (> counter n)
+;; product
+;; (iter (* counter product)
+;; (+ counter 1))))
+;; (iter 1 1))
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+
+;; Exercise 5.3. Design a machine to compute square roots using Newton's method, as described in section 1.1.7:
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+;; Begin by assuming that good-enough? and improve operations are available as primitives. Then show how to expand these in terms of arithmetic operations. Describe each version of the sqrt machine design by drawing a data-path diagram and writing a controller definition in the register-machine language.
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+ ;; Exercise 5.4. Specify register machines that implement each of the following procedures. For each machine, write a controller instruction sequence and draw a diagram showing the data paths.
+
+;; a. Recursive exponentiation:
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+
+;; b. Iterative exponentiation:
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
blob - /dev/null
blob + ef156f22f8f55b75302b7db56828e9a446dc0a1a (mode 644)
--- /dev/null
+++ ex5-9.scm
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (if (label-exp? e)
+ (error "Operation exp cannot operate on labels -- ASSEMBLE"
+ exp)
+ (make-primitive-exp e machine labels)))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; (define amb-machine
+;; (make-machine
+;; '(a)
+;; '()
+;; '(start
+;; (goto (label here))
+;; here
+;; (assign a (const 3))
+;; (goto (label there))
+;; here
+;; (assign a (const 4))
+;; (goto (label there))
+;; there)))
+
+;; (start amb-machine)
+;; (test-case (get-register-contents amb-machine 'a)
+;; 3)
+;; this now raises an error
+
+ ;; Exercise 5.9. The treatment of machine operations above permits them to operate on labels as well as on constants and the contents of registers. Modify the expression-processing procedures to enforce the condition that operations can be used only with registers and constants.
+
+(define op-label-machine
+ (make-machine
+ '(x)
+ `((+ ,+))
+ '((assign x (op +) (label a) (label b)))))
blob - /dev/null
blob + 5283163f5faa6a74f9e09a278f99d418f77e2703 (mode 644)
--- /dev/null
+++ ex5-9.scm~
+(define (make-machine register-names ops controller-text)
+ (let ((machine (make-new-machine)))
+ (for-each (lambda (register-name)
+ ((machine 'allocate-register) register-name))
+ register-names)
+ ((machine 'install-operations) ops)
+ ((machine 'install-instruction-sequence)
+ (assemble controller-text machine))
+ machine))
+(define (make-register name)
+ (let ((contents '*unassigned*))
+ (define (dispatch message)
+ (cond ((eq? message 'get) contents)
+ ((eq? message 'set)
+ (lambda (value) (set! contents value)))
+ (else
+ (error "Unknown request -- REGISTER" message))))
+ dispatch))
+(define (get-contents register)
+ (register 'get))
+(define (set-contents! register value)
+ ((register 'set) value))
+(define (make-stack)
+ (let ((s '())
+ (number-pushes 0)
+ (max-depth 0)
+ (current-depth 0))
+ (define (push x)
+ (set! s (cons x s))
+ (set! number-pushes (+ 1 number-pushes))
+ (set! current-depth (+ 1 current-depth))
+ (set! max-depth (max current-depth max-depth)))
+ (define (pop)
+ (if (null? s)
+ (error "Empty stack -- POP")
+ (let ((top (car s)))
+ (set! s (cdr s))
+ (set! current-depth (- current-depth 1))
+ top)))
+ (define (initialize)
+ (set! s '())
+ (set! number-pushes 0)
+ (set! max-depth 0)
+ (set! current-depth 0)
+ 'done)
+ (define (print-statistics)
+ (newline)
+ (display (list 'total-pushes '= number-pushes
+ 'maximum-depth '= max-depth)))
+ (define (dispatch message)
+ (cond ((eq? message 'push) push)
+ ((eq? message 'pop) (pop))
+ ((eq? message 'initialize) (initialize))
+ ((eq? message 'print-statistics)
+ (print-statistics))
+ (else
+ (error "Unknown request -- STACK" message))))
+ dispatch))
+(define (pop stack)
+ (stack 'pop))
+(define (push stack value)
+ ((stack 'push) value))
+(define (make-new-machine)
+ (let ((pc (make-register 'pc))
+ (flag (make-register 'flag))
+ (stack (make-stack))
+ (the-instruction-sequence '()))
+ (let ((the-ops
+ (list (list 'initialize-stack
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
+ (register-table
+ (list (list 'pc pc) (list 'flag flag))))
+ (define (allocate-register name)
+ (if (assoc name register-table)
+ (error "Multiply defined register: " name)
+ (set! register-table
+ (cons (list name (make-register name))
+ register-table)))
+ 'register-allocated)
+ (define (lookup-register name)
+ (let ((val (assoc name register-table)))
+ (if val
+ (cadr val)
+ (error "Unknown register:" name))))
+ (define (execute)
+ (let ((insts (get-contents pc)))
+ (if (null? insts)
+ 'done
+ (begin
+ ((instruction-execution-proc (car insts)))
+ (execute)))))
+ (define (dispatch message)
+ (cond ((eq? message 'start)
+ (set-contents! pc the-instruction-sequence)
+ (execute))
+ ((eq? message 'install-instruction-sequence)
+ (lambda (seq) (set! the-instruction-sequence seq)))
+ ((eq? message 'allocate-register) allocate-register)
+ ((eq? message 'get-register) lookup-register)
+ ((eq? message 'install-operations)
+ (lambda (ops) (set! the-ops (append the-ops ops))))
+ ((eq? message 'stack) stack)
+ ((eq? message 'operations) the-ops)
+ (else (error "Unknown request -- MACHINE" message))))
+ dispatch)))
+(define (start machine)
+ (machine 'start))
+(define (get-register-contents machine register-name)
+ (get-contents (get-register machine register-name)))
+(define (set-register-contents! machine register-name value)
+ (set-contents! (get-register machine register-name) value)
+ 'done)
+(define (get-register machine reg-name)
+ ((machine 'get-register) reg-name))
+(define (assemble controller-text machine)
+ (extract-labels controller-text
+ (lambda (insts labels)
+ (update-insts! insts labels machine)
+ insts)))
+(define (extract-labels text receive)
+ (if (null? text)
+ (receive '() '())
+ (extract-labels (cdr text)
+ (lambda (insts labels)
+ (let ((next-inst (car text)))
+ (if (symbol? next-inst)
+ (if (label-defined? labels next-inst)
+ (error "Duplicate label -- ASSEMBLE"
+ next-inst)
+ (receive
+ insts
+ (cons (make-label-entry next-inst
+ insts)
+ labels)))
+ (receive
+ (cons (make-instruction next-inst)
+ insts)
+ labels)))))))
+(define (update-insts! insts labels machine)
+ (let ((pc (get-register machine 'pc))
+ (flag (get-register machine 'flag))
+ (stack (machine 'stack))
+ (ops (machine 'operations)))
+ (for-each
+ (lambda (inst)
+ (set-instruction-execution-proc!
+ inst
+ (make-execution-procedure
+ (instruction-text inst) labels machine
+ pc flag stack ops)))
+ insts)))
+(define (make-instruction text)
+ (cons text '()))
+(define (instruction-text inst)
+ (car inst))
+(define (instruction-execution-proc inst)
+ (cdr inst))
+(define (set-instruction-execution-proc! inst proc)
+ (set-cdr! inst proc))
+(define (make-label-entry label-name insts)
+ (cons label-name insts))
+(define (label-defined? labels label-name)
+ (not (false? (assoc label-name labels))))
+(define (lookup-label labels label-name)
+ (let ((val (assoc label-name labels)))
+ (if val
+ (cdr val)
+ (error "Undefined label -- ASSEMBLE" label-name))))
+(define (make-execution-procedure inst labels machine
+ pc flag stack ops)
+ (cond ((eq? (car inst) 'assign)
+ (make-assign inst machine labels ops pc))
+ ((eq? (car inst) 'test)
+ (make-test inst machine labels ops flag pc))
+ ((eq? (car inst) 'branch)
+ (make-branch inst machine labels flag pc))
+ ((eq? (car inst) 'goto)
+ (make-goto inst machine labels pc))
+ ((eq? (car inst) 'save)
+ (make-save inst machine stack pc))
+ ((eq? (car inst) 'restore)
+ (make-restore inst machine stack pc))
+ ((eq? (car inst) 'perform)
+ (make-perform inst machine labels ops pc))
+ (else (error "Unknown instruction type -- ASSEMBLE"
+ inst))))
+(define (make-assign inst machine labels operations pc)
+ (let ((target
+ (get-register machine (assign-reg-name inst)))
+ (value-exp (assign-value-exp inst)))
+ (let ((value-proc
+ (if (operation-exp? value-exp)
+ (make-operation-exp
+ value-exp machine labels operations)
+ (make-primitive-exp
+ (car value-exp) machine labels))))
+ (lambda () ; execution procedure for assign
+ (set-contents! target (value-proc))
+ (advance-pc pc)))))
+(define (assign-reg-name assign-instruction)
+ (cadr assign-instruction))
+(define (assign-value-exp assign-instruction)
+ (cddr assign-instruction))
+(define (advance-pc pc)
+ (set-contents! pc (cdr (get-contents pc))))
+(define (make-test inst machine labels operations flag pc)
+ (let ((condition (test-condition inst)))
+ (if (operation-exp? condition)
+ (let ((condition-proc
+ (make-operation-exp
+ condition machine labels operations)))
+ (lambda ()
+ (set-contents! flag (condition-proc))
+ (advance-pc pc)))
+ (error "Bad TEST instruction -- ASSEMBLE" inst))))
+(define (test-condition test-instruction)
+ (cdr test-instruction))
+(define (make-branch inst machine labels flag pc)
+ (let ((dest (branch-dest inst)))
+ (if (label-exp? dest)
+ (let ((insts
+ (lookup-label labels (label-exp-label dest))))
+ (lambda ()
+ (if (get-contents flag)
+ (set-contents! pc insts)
+ (advance-pc pc))))
+ (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
+(define (branch-dest branch-instruction)
+ (cadr branch-instruction))
+(define (make-goto inst machine labels pc)
+ (let ((dest (goto-dest inst)))
+ (cond ((label-exp? dest)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label dest))))
+ (lambda () (set-contents! pc insts))))
+ ((register-exp? dest)
+ (let ((reg
+ (get-register machine
+ (register-exp-reg dest))))
+ (lambda ()
+ (set-contents! pc (get-contents reg)))))
+ (else (error "Bad GOTO instruction -- ASSEMBLE"
+ inst)))))
+(define (goto-dest goto-instruction)
+ (cadr goto-instruction))
+(define (make-save inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (push stack (get-contents reg))
+ (advance-pc pc))))
+(define (make-restore inst machine stack pc)
+ (let ((reg (get-register machine
+ (stack-inst-reg-name inst))))
+ (lambda ()
+ (set-contents! reg (pop stack))
+ (advance-pc pc))))
+(define (stack-inst-reg-name stack-instruction)
+ (cadr stack-instruction))
+(define (make-perform inst machine labels operations pc)
+ (let ((action (perform-action inst)))
+ (if (operation-exp? action)
+ (let ((action-proc
+ (make-operation-exp
+ action machine labels operations)))
+ (lambda ()
+ (action-proc)
+ (advance-pc pc)))
+ (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
+(define (perform-action inst) (cdr inst))
+(define (make-primitive-exp exp machine labels)
+ (cond ((constant-exp? exp)
+ (let ((c (constant-exp-value exp)))
+ (lambda () c)))
+ ((label-exp? exp)
+ (let ((insts
+ (lookup-label labels
+ (label-exp-label exp))))
+ (lambda () insts)))
+ ((register-exp? exp)
+ (let ((r (get-register machine
+ (register-exp-reg exp))))
+ (lambda () (get-contents r))))
+ (else
+ (error "Unknown expression type -- ASSEMBLE" exp))))
+(define (tagged-list? exp tag)
+ (and (pair? exp) (eq? (car exp) tag)))
+(define (register-exp? exp) (tagged-list? exp 'reg))
+(define (register-exp-reg exp) (cadr exp))
+(define (constant-exp? exp) (tagged-list? exp 'const))
+(define (constant-exp-value exp) (cadr exp))
+(define (label-exp? exp) (tagged-list? exp 'label))
+(define (label-exp-label exp) (cadr exp))
+(define (make-operation-exp exp machine labels operations)
+ (let ((op (lookup-prim (operation-exp-op exp) operations))
+ (aprocs
+ (map (lambda (e)
+ (make-primitive-exp e machine labels))
+ (operation-exp-operands exp))))
+ (lambda ()
+ (apply op (map (lambda (p) (p)) aprocs)))))
+(define (operation-exp? exp)
+ (and (pair? exp) (tagged-list? (car exp) 'op)))
+(define (operation-exp-op operation-exp)
+ (cadr (car operation-exp)))
+(define (operation-exp-operands operation-exp)
+ (cdr operation-exp))
+(define (lookup-prim symbol operations)
+ (let ((val (assoc symbol operations)))
+ (if val
+ (cadr val)
+ (error "Unknown operation -- ASSEMBLE" symbol))))
+
+;; test suite
+
+(define (test-case actual expected)
+ (newline)
+ (display "Actual: ")
+ (display actual)
+ (newline)
+ (display "Expected: ")
+ (display expected)
+ (newline))
+
+(define gcd-machine
+ (make-machine
+ '(a b t)
+ (list (list 'rem remainder) (list '= =))
+ '(test-b
+ (test (op =) (reg b) (const 0))
+ (branch (label gcd-done))
+ (assign t (op rem) (reg a) (reg b))
+ (assign a (reg b))
+ (assign b (reg t))
+ (goto (label test-b))
+ gcd-done)))
+(set-register-contents! gcd-machine 'a 206)
+(set-register-contents! gcd-machine 'b 40)
+(start gcd-machine)
+(test-case (get-register-contents gcd-machine 'a) 2)
+
+(define fib-machine
+ (make-machine
+ '(n val continue)
+ `((< ,<) (- ,-) (+ ,+))
+ '(controller
+ (assign continue (label fib-done))
+ fib-loop
+ (test (op <) (reg n) (const 2))
+ (branch (label immediate-answer))
+ (save continue)
+ (assign continue (label afterfib-n-1))
+ (save n)
+ (assign n (op -) (reg n) (const 1))
+ (goto (label fib-loop))
+ afterfib-n-1
+ (restore n)
+ (restore continue)
+ (assign n (op -) (reg n) (const 2))
+ (save continue)
+ (assign continue (label afterfib-n-2))
+ (save val)
+ (goto (label fib-loop))
+ afterfib-n-2
+ (assign n (reg val))
+ (restore val)
+ (restore continue)
+ (assign val
+ (op +) (reg val) (reg n))
+ (goto (reg continue))
+ immediate-answer
+ (assign val (reg n))
+ (goto (reg continue))
+ fib-done)))
+(set-register-contents! fib-machine 'val 0)
+(set-register-contents! fib-machine 'n 15)
+(start fib-machine)
+(test-case (get-register-contents fib-machine 'val) 610)
+
+(define fact-iter
+ (make-machine
+ '(product counter n)
+ `((> ,>) (* ,*) (+ ,+))
+ '((assign product (const 1))
+ (assign counter (const 1))
+ fact-loop
+ (test (op >) (reg counter) (reg n))
+ (branch (label fact-end))
+ (assign product (op *) (reg counter) (reg product))
+ (assign counter (op +) (reg counter) (const 1))
+ (goto (label fact-loop))
+ fact-end)))
+(set-register-contents! fact-iter 'n 10)
+(start fact-iter)
+(test-case (get-register-contents fact-iter 'product) 3628800)
+
+(define (sqrt x)
+ (define (good-enough? guess)
+ (< (abs (- (square guess) x)) 0.001))
+ (define (improve guess)
+ (average guess (/ x guess)))
+ (define (sqrt-iter guess)
+ (if (good-enough? guess)
+ guess
+ (sqrt-iter (improve guess))))
+ (sqrt-iter 1.0))
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter-ops
+ (make-machine
+ '(guess x)
+ `((good-enough? ,good-enough?)
+ (improve ,improve)
+ (abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ (test (op good-enough?) (reg guess) (reg x))
+ (branch (label sqrt-done))
+ (assign guess (op improve) (reg guess) (reg x))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+
+(set-register-contents! sqrt-iter-ops 'x 27)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 5.19615242)
+
+(define (good-enough? guess x)
+ (< (abs (- (square guess) x)) 0.001))
+(define (improve guess x)
+ (average guess (/ x guess)))
+(define (average x y)
+ (/ (+ x y) 2))
+(define sqrt-iter
+ (make-machine
+ '(guess x temp)
+ `((abs ,abs)
+ (square ,square)
+ (average ,average)
+ (< ,<)
+ (- ,-)
+ (/ ,/))
+ '((assign guess (const 1.0))
+ sqrt-iter
+ ;; (test (op good-enough?) (reg guess) (reg x))
+ (assign temp (op square) (reg guess))
+ (assign temp (op -) (reg temp) (reg x))
+ (assign temp (op abs) (reg temp))
+ (test (op <) (reg temp) (const 0.001))
+ (branch (label sqrt-done))
+ ;; (assign guess (op improve) (reg guess) (reg x))
+ (assign temp (op /) (reg x) (reg guess))
+ (assign guess (op average) (reg guess) (reg temp))
+ (goto (label sqrt-iter))
+ sqrt-done)))
+(set-register-contents! sqrt-iter-ops 'x 91)
+(start sqrt-iter-ops)
+(test-case (get-register-contents sqrt-iter-ops 'guess)
+ 9.53939201)
+
+(define (expt b n)
+ (if (= n 0)
+ 1
+ (* b (expt b (- n 1)))))
+
+(define expt-rec
+ (make-machine
+ '(b n product continue)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign continue (label expt-done))
+ expt-rec
+ (test (op =) (reg n) (const 0))
+ (branch (label base-case))
+ (assign n (op -) (reg n) (const 1))
+ (save continue)
+ (assign continue (label after-b-n-1))
+ (goto (label expt-rec))
+ after-b-n-1
+ (restore continue)
+ (assign product (op *) (reg b) (reg product))
+ (goto (reg continue))
+ base-case
+ (assign product (const 1))
+ (goto (reg continue))
+ expt-done)))
+
+(set-register-contents! expt-rec 'b 3.2)
+(set-register-contents! expt-rec 'n 6)
+(start expt-rec)
+(test-case (get-register-contents expt-rec 'product)
+ 1073.74182)
+
+(define (expt b n)
+ (define (expt-iter counter product)
+ (if (= counter 0)
+ product
+ (expt-iter (- counter 1) (* b product))))
+ (expt-iter n 1))
+
+(define expt-iter
+ (make-machine
+ '(b n counter product)
+ `((= ,=)
+ (* ,*)
+ (- ,-))
+ '((assign counter (reg n))
+ (assign product (const 1))
+ expt-iter
+ (test (op =) (reg counter) (const 0))
+ (branch (label expt-iter-done))
+ (assign counter (op -) (reg counter) (const 1))
+ (assign product (op *) (reg b) (reg product))
+ (goto (label expt-iter))
+ expt-iter-done)))
+(set-register-contents! expt-iter 'b 1.6)
+(set-register-contents! expt-iter 'n 17)
+(start expt-iter)
+(test-case (get-register-contents expt-iter 'product)
+ 2951.47905)
+
+;; Exercise 5.8. The following register-machine code is ambiguous, because the label here is defined more than once:
+
+(define amb-machine
+ (make-machine
+ '(a)
+ '()
+ '(start
+ (goto (label here))
+ here
+ (assign a (const 3))
+ (goto (label there))
+ here
+ (assign a (const 4))
+ (goto (label there))
+ there)))
+
+;; With the simulator as written, what will the contents of register a be when control reaches there? Modify the extract-labels procedure so that the assembler will signal an error if the same label name is used to indicate two different locations.
+
+(start amb-machine)
+(test-case (get-register-contents amb-machine 'a)
+ 3)
+;; extract-labels builds insts/labels from the very last instruction to the first instruction and conses them in that order so that the insts/labels are in the same order as in the instruction
+;; since lookup-label uses assoc, the labels will also be accessed in the same order as the instruction sequence. Therefore, the (goto (label here)) will branch to the first here label and not the second one
+
+ Exercise 5.9. The treatment of machine operations above permits them to operate on labels as well as on constants and the contents of registers. Modify the expression-processing procedures to enforce the condition that operations can be used only with registers and constants.
blob - /dev/null
blob + 900a330458f925f33ac886b5d9099de6145acdb6 (mode 644)
--- /dev/null
+++ test.scm
+10
+(+ 5 3 4)
\ No newline at end of file
