├── README.md ├── code ├── Chapter 1 │ ├── e1-1 │ ├── e1-11 │ ├── e1-12 │ ├── e1-13 │ ├── e1-16 │ ├── e1-17 │ ├── e1-19 │ ├── e1-29 │ ├── e1-3 │ ├── e1-30 │ ├── e1-31 │ ├── e1-32 │ ├── e1-33 │ ├── e1-35 │ ├── e1-36 │ ├── e1-37 │ ├── e1-38 │ ├── e1-39 │ ├── e1-40 │ ├── e1-41 │ ├── e1-42 │ ├── e1-43 │ ├── e1-44 │ ├── e1-45 │ ├── e1-46 │ └── e1-6 ├── Chapter 2 │ ├── e2-1 │ ├── e2-11 │ ├── e2-12 │ ├── e2-17 │ ├── e2-18 │ ├── e2-19 │ ├── e2-2 │ ├── e2-20 │ ├── e2-21 │ ├── e2-23 │ ├── e2-25 │ ├── e2-26 │ ├── e2-27 │ ├── e2-28 │ ├── e2-29 │ ├── e2-29d │ ├── e2-3 │ ├── e2-30 │ ├── e2-30-true │ ├── e2-31 │ ├── e2-32 │ ├── e2-33 │ ├── e2-34 │ ├── e2-35 │ ├── e2-36 │ ├── e2-37 │ ├── e2-38 │ ├── e2-39 │ ├── e2-4 │ ├── e2-40 │ ├── e2-41 │ ├── e2-44 │ ├── e2-45 │ ├── e2-46 │ ├── e2-47 │ ├── e2-48 │ ├── e2-49 │ ├── e2-5 │ ├── e2-50 │ ├── e2-51 │ ├── e2-52 │ ├── e2-54 │ ├── e2-56 │ ├── e2-57 │ ├── e2-58 │ ├── e2-59 │ ├── e2-6 │ ├── e2-60 │ ├── e2-61 │ ├── e2-62 │ ├── e2-63 │ ├── e2-64 │ ├── e2-65 │ ├── e2-66 │ ├── e2-67 │ ├── e2-68 │ ├── e2-69 │ ├── e2-7 │ ├── e2-70 │ ├── e2-71 │ ├── e2-72 │ ├── e2-73 │ ├── e2-74 │ ├── e2-75 │ ├── e2-76 │ ├── e2-77 │ ├── e2-78 │ ├── e2-79 │ ├── e2-8 │ ├── e2-80 │ ├── e2-81 │ ├── e2-82 │ ├── e2-83 │ ├── e2-84 │ ├── e2-85 │ ├── e2-86 │ ├── e2-87 │ ├── e2-88 │ ├── e2-89 │ ├── e2-9 │ ├── e2-90 │ ├── e2-91 │ ├── e2-93 │ ├── e2-94 │ ├── e2-95 │ ├── e2-96 │ ├── e2-97 │ └── e2-queen ├── Chapter 3 │ ├── e3-1 │ ├── e3-10 │ ├── e3-11 │ ├── e3-12 │ ├── e3-13 │ ├── e3-14 │ ├── e3-15 │ ├── e3-16 │ ├── e3-17 │ ├── e3-18 │ ├── e3-19 │ ├── e3-2 │ ├── e3-20 │ ├── e3-21 │ ├── e3-22 │ ├── e3-23 │ ├── e3-24 │ ├── e3-25 │ ├── e3-26 │ ├── e3-27 │ ├── e3-28 │ ├── e3-29 │ ├── e3-3 │ ├── e3-30 │ ├── e3-31 │ ├── e3-32 │ ├── e3-33 │ ├── e3-34 │ ├── e3-35 │ ├── e3-36 │ ├── e3-37 │ ├── e3-38 │ ├── e3-39 │ ├── e3-4 │ ├── e3-40 │ ├── e3-41 │ ├── e3-42 │ ├── e3-43 │ ├── e3-44 │ ├── e3-45 │ ├── e3-46 │ ├── e3-47 │ ├── e3-48 │ ├── e3-49 │ ├── e3-5 │ ├── e3-50 │ ├── e3-51 │ ├── e3-52 │ ├── e3-53 │ ├── e3-54 │ ├── e3-55 │ ├── e3-56 │ ├── e3-57 │ ├── e3-58 │ ├── e3-59 │ ├── e3-6 │ ├── e3-60 │ ├── e3-61 │ ├── e3-63 │ ├── e3-64 │ ├── e3-65 │ ├── e3-66 │ ├── e3-67 │ ├── e3-68 │ ├── e3-69 │ ├── e3-7 │ ├── e3-70 │ ├── e3-71 │ ├── e3-72 │ ├── e3-73 │ ├── e3-74 │ ├── e3-75 │ ├── e3-76 │ ├── e3-77 │ ├── e3-78 │ ├── e3-79 │ ├── e3-8 │ ├── e3-80 │ ├── e3-81 │ ├── e3-82 │ └── e3-9 ├── Chapter 4 │ ├── e4-1 │ ├── e4-10 │ ├── e4-11 │ ├── e4-12 │ ├── e4-13 │ ├── e4-14 │ ├── e4-16 │ ├── e4-17 │ ├── e4-18 │ ├── e4-19 │ ├── e4-2 │ ├── e4-20 │ ├── e4-21 │ ├── e4-22 │ ├── e4-23 │ ├── e4-25 │ ├── e4-26 │ ├── e4-27 │ ├── e4-28 │ ├── e4-29 │ ├── e4-3 │ ├── e4-30 │ ├── e4-31 │ ├── e4-32 │ ├── e4-33 │ ├── e4-34 │ ├── e4-35 │ ├── e4-36 │ ├── e4-37 │ ├── e4-38 │ ├── e4-39 │ ├── e4-4 │ ├── e4-40 │ ├── e4-41 │ ├── e4-42 │ ├── e4-43 │ ├── e4-44 │ ├── e4-45 │ ├── e4-46 │ ├── e4-47 │ ├── e4-48 │ ├── e4-49 │ ├── e4-5 │ ├── e4-50 │ ├── e4-51 │ ├── e4-52 │ ├── e4-53 │ ├── e4-54 │ ├── e4-55 │ ├── e4-56 │ ├── e4-57 │ ├── e4-58 │ ├── e4-59 │ ├── e4-6 │ ├── e4-60 │ ├── e4-61 │ ├── e4-62 │ ├── e4-63 │ ├── e4-7 │ ├── e4-8 │ └── e4-9 ├── Chapter 5 │ ├── e5-11 │ ├── e5-12 │ ├── e5-13 │ ├── e5-14 │ ├── e5-15 │ ├── e5-16 │ ├── e5-17 │ ├── e5-18 │ ├── e5-19 │ ├── e5-20 │ ├── e5-21 │ ├── e5-22 │ ├── e5-23 │ ├── e5-24 │ ├── e5-25 │ ├── e5-31 │ ├── e5-32 │ ├── e5-33 │ ├── e5-34 │ ├── e5-35 │ └── e5-36 └── test └── sicp.pdf /README.md: -------------------------------------------------------------------------------- 1 | # SICP 习题集 2 | 3 | 把 SICP 学了一遍，这里是我写的所有习题。 4 | 5 | - 第一章：26 道 6 | - 第二章：88 道 7 | - 第三章：81 道 8 | - 第四章：61 道 9 | - 第五章：21 道 10 | 11 | 共计：277 道。 12 | 13 | 写了一篇博客，介绍我的学习感受和一些心得：[我如何用二十天刷完 SICP](http://numbbbbb.com/2016/03/28/20160328_%E6%88%91%E5%A6%82%E4%BD%95%E7%94%A8%E4%B8%A4%E5%91%A8%E6%97%B6%E9%97%B4%E5%88%B7%E5%AE%8C%20SICP/)。 14 | 15 | ## 注意 16 | 17 | 我没有完成全部习题，没做的那些题主要是： 18 | 19 | - 证明题：数量很少 20 | - 图表题：编辑器画不了图，我尽量用文字表示 21 | - 太难的题：主要集中在最后一章 22 | 23 | 此外，我的答案**仅供参考**。欢迎讨论交流，不欢迎喷。 24 | 25 | ## 开源协议 26 | 27 | 基于[WTFPL协议](http://en.wikipedia.org/wiki/WTFPL)开源。 28 | -------------------------------------------------------------------------------- /code/Chapter 1/e1-1: -------------------------------------------------------------------------------- 1 | (define (abs x) 2 | (cond ((> x 0) x) 3 | ((= x 0) 0) 4 | ((< x 0) (- x)))) 5 | 6 | (define (abs2 x) 7 | (cond ((< x 0) (- x)) 8 | (else x))) 9 | 10 | (define (abs3 x) 11 | (if (< x 0) 12 | (- x) 13 | x)) -------------------------------------------------------------------------------- /code/Chapter 1/e1-11: -------------------------------------------------------------------------------- 1 | (define (f-cur n) 2 | (cond ((< n 3) n) 3 | (else (+ (f-cur (- n 1)) (* 2 (f-cur (- n 2))) (* 3 (f-cur (- n 3))))))) 4 | (f-cur 5) 5 | 6 | (define (f-iter n) 7 | (define (f-iter-internal a b c count) 8 | (cond ((= count 0) (+ (* 3 a) (* 2 b) c)) 9 | (else (f-iter-internal b c (+ (* 3 a) (* 2 b) c) (- count 1))))) 10 | (cond ((< n 3) n) 11 | (else (f-iter-internal 0 1 2 (- n 3))))) 12 | 13 | (f-iter 5) -------------------------------------------------------------------------------- /code/Chapter 1/e1-12: -------------------------------------------------------------------------------- 1 | (define (pascal n) 2 | (define (cal-number x y) 3 | (cond ((= x 1) 1) 4 | ((= y 1) 1) 5 | ((= x y) 1) 6 | (else (+ (cal-number (- x 1) (- y 1)) (cal-number x (- y 1)))) 7 | ) 8 | ) 9 | (define (pascal-line now total) 10 | (define (display-line-internal now total) 11 | (display (cal-number now total)) 12 | (cond ((< now total) (display-line-internal (+ now 1) total)) 13 | ) 14 | ) 15 | (display-line-internal 1 now) 16 | (display "\n") 17 | (cond ((< now total) (pascal-line (+ now 1) total))) 18 | ) 19 | (pascal-line 1 n) 20 | ) 21 | (pascal 5) -------------------------------------------------------------------------------- /code/Chapter 1/e1-13: -------------------------------------------------------------------------------- 1 | (define (check n) 2 | (define (fib n) 3 | (define (fib-iter a b step) 4 | (cond ((= step 0) (+ a b)) 5 | (else (fib-iter b (+ a b) (- step 1))) 6 | ) 7 | ) 8 | (cond ((< n 2) n) 9 | (else (fib-iter 0 1 (- n 2))) 10 | ) 11 | ) 12 | (define (xx n) 13 | (/ (- (expt (/ (+ 1 (sqrt 5.0)) 2) n) (expt (/ (- 1 (sqrt 5.0)) 2) n)) (sqrt 5.0)) 14 | ) 15 | (display (fib n)) 16 | (display "\n") 17 | (display (xx n)) 18 | ) 19 | (check 9) -------------------------------------------------------------------------------- /code/Chapter 1/e1-16: -------------------------------------------------------------------------------- 1 | (define (even? n) 2 | (= (remainder n 2) 0)) 3 | (define (exp-iter b n) 4 | (define (exp-iter-internal a b n) 5 | (cond ((= n 1) (* a b)) 6 | ((even? n) (exp-iter-internal a (* b b) (/ n 2))) 7 | (else (exp-iter-internal (* a b) (* b b) (/ (- n 1) 2))) 8 | ) 9 | ) 10 | (exp-iter-internal 1 b n) 11 | ) 12 | (exp-iter 2 10) -------------------------------------------------------------------------------- /code/Chapter 1/e1-17: -------------------------------------------------------------------------------- 1 | (define (even? n) 2 | (= (remainder n 2) 0) 3 | ) 4 | (define (* a b) (if (= b 0) 5 | 0 6 | (+ a (* a (- b 1))))) 7 | (define (double x) (* x 2)) 8 | (define (halve x) (/ x 2)) 9 | (define (exp-iter b n) 10 | (define (exp-iter-internal a b n) 11 | (cond ((= n 1) (* a b)) 12 | ((even? n) (exp-iter-internal a (* b b) (halve n))) 13 | (else (exp-iter-internal (* a b) (* b b) (halve (- n 1)))) 14 | ) 15 | ) 16 | (exp-iter-internal 1 b n) 17 | ) 18 | (exp-iter 2 10) -------------------------------------------------------------------------------- /code/Chapter 1/e1-19: -------------------------------------------------------------------------------- 1 | (define (even? n) 2 | (= (remainder n 2) 0) 3 | ) 4 | (define (fib n) (fib-iter 1 0 0 1 n)) 5 | (define (fib-iter a b p q count) (cond ((= count 0) b) 6 | ((even? count) 7 | (fib-iter a b (+ (square p) (square q)) (+ (* 2 p q) (square q)) (/ count 2))) 8 | (else (fib-iter (+ (* b q) (* a q) (* a p)) (+ (* b p) (* a q)) p q (- count 1))))) 9 | (fib 1000) -------------------------------------------------------------------------------- /code/Chapter 1/e1-29: -------------------------------------------------------------------------------- 1 | (define (even? n) 2 | (= (remainder n 2) 0) 3 | ) 4 | (define (sum term a next b) (if (> a b) 5 | 0 6 | (+ (term a) 7 | (sum term (next a) next b))) 8 | ) 9 | (define (integral f a b n) 10 | (define (next x) 11 | (+ x 1) 12 | ) 13 | (define (h) (/ (- b a) n)) 14 | (define (add-it x) 15 | (cond ((= x 0) (f (+ a (* x (h))))) 16 | ((= x n) (f (+ a (* x (h))))) 17 | ((even? x) (* 2 (f (+ a (* x (h)))))) 18 | (else (* 4 (f (+ a (* x (h)))))) 19 | ) 20 | ) 21 | (* (/ (h) 3.0) (sum add-it 0 next n)) 22 | ) 23 | (define (cube x) (* x x x)) 24 | (integral cube 0 1 1000) -------------------------------------------------------------------------------- /code/Chapter 1/e1-3: -------------------------------------------------------------------------------- 1 | (define (e13 a b c) 2 | (cond ((and (< a b) (< a c)) (+ b c)) 3 | ((and (< b a) (< b c)) (+ a c)) 4 | (else (+ a b)))) 5 | 6 | (e13 1 2 3) 7 | (e13 3 2 1) 8 | (e13 1 3 2) -------------------------------------------------------------------------------- /code/Chapter 1/e1-30: -------------------------------------------------------------------------------- 1 | (define (even? n) 2 | (= (remainder n 2) 0) 3 | ) 4 | (define (sum term a next b) 5 | (define (iter a result) 6 | (if (> a b) result 7 | (iter (next a) (+ result (term a)))) 8 | ) 9 | (iter a 0) 10 | ) 11 | 12 | (define (integral f a b n) 13 | (define (next x) 14 | (+ x 1) 15 | ) 16 | (define (h) (/ (- b a) n)) 17 | (define (add-it x) 18 | (cond ((= x 0) (f (+ a (* x (h))))) 19 | ((= x n) (f (+ a (* x (h))))) 20 | ((even? x) (* 2 (f (+ a (* x (h)))))) 21 | (else (* 4 (f (+ a (* x (h)))))) 22 | ) 23 | ) 24 | (* (/ (h) 3.0) (sum add-it 0 next n)) 25 | ) 26 | (define (cube x) (* x x x)) 27 | (integral cube 0 1 1000) -------------------------------------------------------------------------------- /code/Chapter 1/e1-31: -------------------------------------------------------------------------------- 1 | (define (even? n) 2 | (= (remainder n 2) 0) 3 | ) 4 | (define (product-iter term a next b) 5 | (define (iter a result) 6 | (if (> a b) result 7 | (iter (next a) (* result (term a)))) 8 | ) 9 | (iter a 1) 10 | ) 11 | (define (product-recur term a next b) ( 12 | if (> a b) 13 | 1 14 | (* (term a) 15 | (product-recur term (next a) next b) 16 | ) 17 | ) 18 | ) 19 | 20 | (define (factorial n) 21 | (define (next x) 22 | (+ x 1) 23 | ) 24 | (define (get x) 25 | (/ 26 | (if (even? (+ x 2)) 27 | (+ x 2) 28 | (+ x 3) 29 | ) 30 | (if (even? (+ x 2)) 31 | (+ x 3.0) 32 | (+ x 2.0) 33 | ) 34 | ) 35 | ) 36 | (display (* 4 (product-iter get 0 next n))) 37 | (display (* 4 (product-recur get 0 next n))) 38 | ) 39 | (factorial 1000) -------------------------------------------------------------------------------- /code/Chapter 1/e1-32: -------------------------------------------------------------------------------- 1 | (define (accumulate-recur combiner null-value term a next b) 2 | ( 3 | if (> a b) 4 | null-value 5 | (combiner (term a) 6 | (accumulate-recur combiner null-value term (next a) next b) 7 | ) 8 | ) 9 | ) 10 | (define (accumulate-iter combiner null-value term a next b) 11 | (define (iter a result) 12 | (if (> a b) result 13 | (iter (next a) (combiner result (term a)))) 14 | ) 15 | (iter a null-value) 16 | ) 17 | 18 | ; above are two types accumulate 19 | 20 | (define (sum-recur term a next b) 21 | (accumulate-recur + 0 term a next b) 22 | ) 23 | (define (sum-iter term a next b) 24 | (accumulate-iter + 0 term a next b) 25 | ) 26 | (define (integral f a b n) 27 | (define (next x) 28 | (+ x 1) 29 | ) 30 | (define (h) (/ (- b a) n)) 31 | (define (add-it x) 32 | (cond ((= x 0) (f (+ a (* x (h))))) 33 | ((= x n) (f (+ a (* x (h))))) 34 | ((even? x) (* 2 (f (+ a (* x (h)))))) 35 | (else (* 4 (f (+ a (* x (h)))))) 36 | ) 37 | ) 38 | (display (* (/ (h) 3.0) (sum-iter add-it 0 next n))) 39 | (display (* (/ (h) 3.0) (sum-recur add-it 0 next n))) 40 | ) 41 | (define (cube x) (* x x x)) 42 | (integral cube 0 1 1000) 43 | 44 | ; above are tests about sum 45 | 46 | (define (product-recur term a next b) 47 | (accumulate-recur * 1 term a next b) 48 | ) 49 | (define (product-iter term a next b) 50 | (accumulate-iter * 1 term a next b) 51 | ) 52 | (define (factorial n) 53 | (define (next x) 54 | (+ x 1) 55 | ) 56 | (define (get x) 57 | (/ 58 | (if (even? (+ x 2)) 59 | (+ x 2) 60 | (+ x 3) 61 | ) 62 | (if (even? (+ x 2)) 63 | (+ x 3.0) 64 | (+ x 2.0) 65 | ) 66 | ) 67 | ) 68 | (display (* 4 (product-iter get 0 next n))) 69 | (display (* 4 (product-recur get 0 next n))) 70 | ) 71 | (factorial 1000) 72 | 73 | ; above are tests about product -------------------------------------------------------------------------------- /code/Chapter 1/e1-33: -------------------------------------------------------------------------------- 1 | (define (filtered-accumulate-recur filter combiner null-value term a next b) 2 | ( 3 | if (> a b) 4 | null-value 5 | (combiner (if (filter (term a)) (term a) null-value) 6 | (filtered-accumulate-recur filter combiner null-value term (next a) next b) 7 | ) 8 | ) 9 | ) 10 | (define (filtered-accumulate-iter filter combiner null-value term a next b) 11 | (define (iter a result) 12 | (if (> a b) result 13 | (iter (next a) (combiner result (if (filter (term a)) (term a) null-value)))) 14 | ) 15 | (iter a null-value) 16 | ) 17 | 18 | ; above are two types accumulate 19 | 20 | (define (filtered-sum-recur filter term a next b) 21 | (filtered-accumulate-recur filter + 0 term a next b) 22 | ) 23 | (define (filtered-sum-iter filter term a next b) 24 | (filtered-accumulate-iter filter + 0 term a next b) 25 | ) 26 | 27 | (define (filtered-interval a b) 28 | (define (next a) 29 | (+ a 1) 30 | ) 31 | (define (term a) 32 | a 33 | ) 34 | (define (smallest-divisor n) (find-divisor n 2)) 35 | (define (find-divisor n test-divisor) (cond ((> (square test-divisor) n) n) 36 | ((divides? test-divisor n) test-divisor) 37 | (else (find-divisor n (+ test-divisor 1))))) 38 | (define (divides? a b) (= (remainder b a) 0)) 39 | (define (prime? a) 40 | (= a (smallest-divisor a)) 41 | ) 42 | (display (filtered-sum-recur prime? term a next b)) 43 | (display (filtered-sum-iter prime? term a next b)) 44 | ) 45 | (filtered-interval 0 100) -------------------------------------------------------------------------------- /code/Chapter 1/e1-35: -------------------------------------------------------------------------------- 1 | (define tolerance 0.00001) 2 | (define (fixed-point f first-guess) 3 | (define (close-enough? v1 v2) (< (abs (- v1 v2)) 4 | tolerance) 5 | ) 6 | (define (try guess) 7 | (let ((next (f guess))) 8 | (if (close-enough? guess next) 9 | next 10 | (try next))) 11 | ) 12 | (try first-guess) 13 | ) 14 | (fixed-point (lambda (x) (+ 1 (/ 1 x))) 1.0) -------------------------------------------------------------------------------- /code/Chapter 1/e1-36: -------------------------------------------------------------------------------- 1 | (define tolerance 0.00001) 2 | (define (fixed-point f first-guess) 3 | (define (close-enough? v1 v2) (< (abs (- v1 v2)) 4 | tolerance) 5 | ) 6 | (define (try guess) 7 | (let ((next (f guess))) 8 | (if (close-enough? guess next) 9 | next 10 | (try next)) 11 | (display next) 12 | (newline) 13 | ) 14 | ) 15 | (try first-guess) 16 | ) 17 | (fixed-point (lambda (x) (/ (log 1000) (log x))) 2.0) -------------------------------------------------------------------------------- /code/Chapter 1/e1-37: -------------------------------------------------------------------------------- 1 | (define (cont-frac-recur n d k) 2 | (define (cont-frac-internal n d k now) 3 | (if (> now k) 4 | 0 5 | (/ (n now) (+ (d now) (cont-frac-internal n d k (+ now 1)))) 6 | ) 7 | ) 8 | (cont-frac-internal n d k 1) 9 | ) 10 | 11 | (cont-frac-recur (lambda (i) 1.0) (lambda (i) 1.0) 1000) 12 | 13 | ; above is recursive implement 14 | 15 | (define (cont-frac-iter n d k) 16 | (define (cont-frac-internal n d k result) 17 | (if (= k 0) 18 | result 19 | (cont-frac-internal n d (- k 1) (/ (n k) (+ (d k) result))) 20 | ) 21 | ) 22 | (cont-frac-internal n d k 0) 23 | ) 24 | 25 | (cont-frac-iter (lambda (i) 1.0) (lambda (i) 1.0) 1000) -------------------------------------------------------------------------------- /code/Chapter 1/e1-38: -------------------------------------------------------------------------------- 1 | (define (e-iter n d k) 2 | (define (cont-frac-internal n d k result) 3 | (if (= k 0) 4 | result 5 | (cont-frac-internal n d (- k 1) (/ (n k) (+ (d k) result))) 6 | ) 7 | ) 8 | (cont-frac-internal n d k 0) 9 | ) 10 | 11 | (e-iter (lambda (i) 1.0) 12 | (lambda (i) ( 13 | if (= (remainder (- i 2) 3) 0) 14 | (* ( + (/ (- i 2) 3) 1) 2) 15 | 1 16 | ) 17 | ) 18 | 1000 19 | ) -------------------------------------------------------------------------------- /code/Chapter 1/e1-39: -------------------------------------------------------------------------------- 1 | (define (tan-cf x k) 2 | (define (tan-cf-internal x k result) 3 | (if (= k 1) 4 | (/ x (- 1 result)) 5 | (tan-cf-internal x (- k 1) (/ (square x) (- (- (* k 2) 1) result))) 6 | ) 7 | ) 8 | (tan-cf-internal x k 0.0) 9 | ) 10 | 11 | (tan-cf 3.14 10000) 12 | (tan 3.14) -------------------------------------------------------------------------------- /code/Chapter 1/e1-40: -------------------------------------------------------------------------------- 1 | (define (dx) 0.001) 2 | (define (newtons-method g guess) (fixed-point (newton-transform g) guess)) 3 | (define (newton-transform g) 4 | (lambda (x) (- x (/ (g x) ((deriv g) x))))) 5 | (define (deriv g) 6 | (lambda (x) (/ (- (g (+ x (dx))) (g x)) (dx)))) 7 | (define tolerance 0.00001) 8 | (define (fixed-point f first-guess) 9 | (define (close-enough? v1 v2) (< (abs (- v1 v2)) 10 | tolerance)) (define (try guess) 11 | (let ((next (f guess))) 12 | (if (close-enough? guess next) 13 | next 14 | (try next)))) 15 | (try first-guess)) 16 | (define (cubic a b c) 17 | (lambda (x) (+ (* x x x) (* a (* x x)) (* b x) c)) 18 | ) 19 | (newtons-method (cubic 1 1 1) 1) -------------------------------------------------------------------------------- /code/Chapter 1/e1-41: -------------------------------------------------------------------------------- 1 | (define (inc x) (+ x 1)) 2 | (define (double f) (lambda (x) (f (f x)))) 3 | (((double (double double)) inc) 5) -------------------------------------------------------------------------------- /code/Chapter 1/e1-42: -------------------------------------------------------------------------------- 1 | (define (inc x) (+ x 1)) 2 | (define (compose f g) 3 | (lambda (x) (f (g x))) 4 | ) 5 | ((compose square inc) 6) -------------------------------------------------------------------------------- /code/Chapter 1/e1-43: -------------------------------------------------------------------------------- 1 | (define (repeated f n) 2 | (if (= n 1) 3 | (lambda (x) (f x)) 4 | (lambda (x) (f ((repeated f (- n 1)) x))) 5 | ) 6 | ) 7 | ((repeated square 2) 5) -------------------------------------------------------------------------------- /code/Chapter 1/e1-44: -------------------------------------------------------------------------------- 1 | (define (repeated f n) 2 | (if (= n 1) 3 | (lambda (x) (f x)) 4 | (lambda (x) (f ((repeated f (- n 1)) x))) 5 | ) 6 | ) 7 | (define (smoothing f) 8 | (let ((dx 0.001)) 9 | (lambda (x) (/ (+ (f (- x dx)) (f x) (f (+ x dx))) 3)) 10 | ) 11 | ) 12 | (define (n-smoothing n) 13 | (repeated smoothing n) 14 | ) 15 | (((n-smoothing 2) square) 5) -------------------------------------------------------------------------------- /code/Chapter 1/e1-45: -------------------------------------------------------------------------------- 1 | (define (repeated f n) 2 | (if (= n 1) 3 | (lambda (x) (f x)) 4 | (lambda (x) (f ((repeated f (- n 1)) x))) 5 | ) 6 | ) 7 | (define tolerance 0.00001) 8 | (define (fixed-point f first-guess) 9 | (define (close-enough? v1 v2) (< (abs (- v1 v2)) 10 | tolerance)) (define (try guess) 11 | (let ((next (f guess))) 12 | (if (close-enough? guess next) 13 | next 14 | (try next)))) 15 | (try first-guess)) 16 | (define (average a b) 17 | (/ (+ a b) 2) 18 | ) 19 | (define (average-damp f) 20 | (lambda (x) (average x (f x)))) 21 | (define (n-root x n) 22 | (define (check x) 23 | (if (< x 2) 1 x) 24 | ) 25 | (fixed-point ((repeated average-damp (check (- n 2))) (lambda (y) (/ x ((repeated (lambda (x) (* x y)) (check (- n 2))) y) ))) 26 | 1.0) 27 | ) 28 | (n-root 16 4) -------------------------------------------------------------------------------- /code/Chapter 1/e1-46: -------------------------------------------------------------------------------- 1 | (define (iterative-improve enough? improve) 2 | (lambda (guess) 3 | (let ((next (improve guess))) 4 | (if (enough? guess next) 5 | next 6 | ((iterative-improve enough? improve) next) 7 | ) 8 | ) 9 | ) 10 | ) 11 | 12 | ; implement iterative-improve 13 | 14 | (define (repeated f n) 15 | (if (= n 1) 16 | (lambda (x) (f x)) 17 | (lambda (x) (f ((repeated f (- n 1)) x))) 18 | ) 19 | ) 20 | (define tolerance 0.00001) 21 | (define (fixed-point f first-guess) 22 | (define (close-enough? v1 v2) (< (abs (- v1 v2)) 23 | tolerance)) 24 | (define (try guess) 25 | (let ((next (f guess))) 26 | (if (close-enough? guess next) 27 | next 28 | (try next)))) 29 | ((iterative-improve close-enough? try) first-guess) 30 | ) 31 | (define (average a b) 32 | (/ (+ a b) 2) 33 | ) 34 | (define (average-damp f) 35 | (lambda (x) (average x (f x)))) 36 | (define (n-root x n) 37 | (define (check x) 38 | (if (< x 2) 1 x) 39 | ) 40 | (fixed-point ((repeated average-damp (check (- n 2))) (lambda (y) (/ x ((repeated (lambda (x) (* x y)) (check (- n 2))) y) ))) 41 | 1.0) 42 | ) 43 | (n-root 256 8) -------------------------------------------------------------------------------- /code/Chapter 1/e1-6: -------------------------------------------------------------------------------- 1 | (define (cube x) (cube-iter 1.0 x 0.0)) 2 | (define (good-enough? guess last) 3 | (< (/ (abs (- guess last)) guess) 0.00001)) 4 | (define (average x y) (/ (+ x y) 2)) 5 | (define (improve y x) (/ (+ (/ x (square y)) (* 2 y)) 3)) 6 | (define (cube-iter guess x last) 7 | (if (good-enough? guess last) 8 | guess 9 | (cube-iter (improve guess x) x guess))) 10 | (cube 27) 11 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-1: -------------------------------------------------------------------------------- 1 | (define (gcd n d) 2 | 1 3 | ) 4 | 5 | ; mock gcd 6 | 7 | (define (make-rat n d positive) 8 | (let ((g (gcd n d))) 9 | (if positive 10 | (cons (/ n g) (/ d g)) 11 | (cons (- 0 (/ n g)) (/ d g)) 12 | ) 13 | ) 14 | ) 15 | 16 | (make-rat 1 3 #f) -------------------------------------------------------------------------------- /code/Chapter 2/e2-11: -------------------------------------------------------------------------------- 1 | (define (pos x) 2 | (> x 0) 3 | ) 4 | 5 | (define (mul-interval x y) 6 | (cond ((and (pos (upper-bound x)) (pos (lower-bound x)) (pos (upper-bound y)) (pos (lower-bound y))) (make-interval (* (lower-bound x) (lower-bound y)) (* (upper-bound x) (upper-bound y)))) 7 | 8 | ((and (pos (upper-bound x)) (pos (lower-bound x)) (pos (upper-bound y)) (not (pos (lower-bound y)))) (make-interval (* (upper-bound x) (lower-bound y)) (* (upper-bound x) (upper-bound y)))) 9 | 10 | ((and (pos (upper-bound x)) (pos (lower-bound x)) (not (pos (upper-bound y))) (not (pos (lower-bound y)))) (make-interval (* (upper-bound x) (lower-bound y)) (* (lower-bound x) (power-bound y)))) 11 | 12 | ((and (pos (upper-bound x)) (not (pos (lower-bound x))) (pos (upper-bound y)) (pos (lower-bound y))) (make-interval (* (lower-bound x) (upper-bound y)) (* (upper-bound x) (upper-bound y)))) 13 | 14 | ((and (pos (upper-bound x)) (not (pos (lower-bound x))) (pos (upper-bound y)) (not (pos (lower-bound y)))) (let ((p1 (* (lower-bound x) (lower-bound y))) 15 | (p2 (* (lower-bound x) (upper-bound y))) 16 | (p3 (* (upper-bound x) (lower-bound y))) 17 | (p4 (* (upper-bound x) (upper-bound y)))) 18 | (make-interval (min p1 p2 p3 p4) 19 | (max p1 p2 p3 p4)))) 20 | 21 | ((and (pos (upper-bound x)) (not (pos (lower-bound x))) (not (pos (upper-bound y))) (not (pos (lower-bound y)))) (make-interval (* (lower-bound x) (lower-bound y)) (* (upper-bound x) (lower-bound y)))) 22 | 23 | ((and (not (pos (upper-bound x))) (not (pos (lower-bound x))) (pos (upper-bound y)) (pos (lower-bound y))) (make-interval (* (lower-bound x) (upper-bound y)) (* (upper-bound x) (lower-bound y)))) 24 | 25 | ((and (not (pos (upper-bound x))) (not (pos (lower-bound x))) (pos (upper-bound y)) (not (pos (lower-bound y)))) (make-interval (* (lower-bound x) (upper-bound y)) (* (lower-bound x) (lower-bound y)))) 26 | 27 | ((and (not (pos (upper-bound x))) (not (pos (lower-bound x))) (not (pos (upper-bound y))) (not (pos (lower-bound y)))) (make-interval (* (upper-bound x) (upper-bound y)) (* (lower-bound x) (lower-bound y)))) 28 | ) 29 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-12: -------------------------------------------------------------------------------- 1 | (define (make-center-width c percent) 2 | (make-interval (- c (* c percent)) (+ c (* c percent))) 3 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-17: -------------------------------------------------------------------------------- 1 | (define (last-pair a) 2 | (if null? (cdr a) 3 | a 4 | (last-pair (cdr a)) 5 | ) 6 | ) 7 | 8 | (last-pair (list 23 72 149 34)) -------------------------------------------------------------------------------- /code/Chapter 2/e2-18: -------------------------------------------------------------------------------- 1 | (define (reverse a) 2 | (if (null? a) 3 | '() 4 | (append (reverse (cdr a)) (list (car a))) 5 | ) 6 | ) 7 | 8 | (reverse (list 1 4 9 16 25)) -------------------------------------------------------------------------------- /code/Chapter 2/e2-19: -------------------------------------------------------------------------------- 1 | (define (first-denomination a) 2 | (car a) 3 | ) 4 | (define (except-first-denomination a) 5 | (cdr a) 6 | ) 7 | (define (no-more? a) 8 | (null? a) 9 | ) 10 | 11 | ; order doesn't affect the answer, because all posible answer will be found, no matter sonner or later. 12 | 13 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-2: -------------------------------------------------------------------------------- 1 | (define (print-point p) 2 | (newline) 3 | (display "(") 4 | (display (x-point p)) 5 | (display ",") 6 | (display (y-point p)) 7 | (display ")") 8 | ) 9 | (define (start-segment line) 10 | (car line) 11 | ) 12 | (define (end-segment line) 13 | (cdr line) 14 | ) 15 | (define (make-segment start-point end-point) 16 | (cons start-point end-point) 17 | ) 18 | (define (x-point point) 19 | (car point) 20 | ) 21 | (define (y-point point) 22 | (cdr point) 23 | ) 24 | (define (make-point x y) 25 | (cons x y) 26 | ) 27 | (define (midpoint-segment line) 28 | (make-point 29 | (/ (+ (x-point (start-segment line)) (x-point (end-segment line))) 2) 30 | (/ (+ (y-point (start-segment line)) (y-point (end-segment line))) 2) 31 | ) 32 | ) 33 | (print-point (midpoint-segment (make-segment (make-point 1 4) (make-point 5 8)))) -------------------------------------------------------------------------------- /code/Chapter 2/e2-20: -------------------------------------------------------------------------------- 1 | (define (even? x) 2 | (= (remainder x 2) 0) 3 | ) 4 | (define (same-parity . a) 5 | (define (filter b even) 6 | (if (not (null? b)) 7 | ( 8 | cond 9 | (even (if (even? (car b)) (cons (car b) (filter (cdr b) even)) (filter (cdr b) even))) 10 | (else (if (not (even? (car b))) (cons (car b) (filter (cdr b) even)) (filter (cdr b) even))) 11 | ) 12 | '() 13 | ) 14 | ) 15 | (cons (car a) (filter (cdr a) (even? (car a)))) 16 | ) 17 | 18 | (same-parity 2 3 4 5 6) -------------------------------------------------------------------------------- /code/Chapter 2/e2-21: -------------------------------------------------------------------------------- 1 | (define (square-list items) 2 | (if (null? items) 3 | '() 4 | (cons (square (car items)) (square-list (cdr items)))) 5 | ) 6 | (square-list (list 1 2 3 4)) 7 | 8 | ; first implement 9 | 10 | (define (square-list-2 items) 11 | (map (lambda (x) (square x)) items) 12 | ) 13 | (square-list-2 (list 1 2 3 4)) 14 | 15 | ; second implement 16 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-23: -------------------------------------------------------------------------------- 1 | (define (for-each proc items) 2 | (if (null? items) 3 | '() 4 | (proc (car items)) 5 | (for-each proc (cdr items)) 6 | ) 7 | ) 8 | 9 | (for-each 10 | (lambda (x) 11 | (newline) 12 | (display x) 13 | ) 14 | (list 57 321 88) 15 | ) 16 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-25: -------------------------------------------------------------------------------- 1 | (define (first items) 2 | (car (cdr (car (cdr (cdr items))))) 3 | ) 4 | (define (second items) 5 | (car (car items)) 6 | ) 7 | (define (third items) 8 | (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr items)))))))))))) 9 | ) 10 | 11 | (first (list 1 3 (list 5 7) 9)) 12 | (second (list (list 7))) 13 | (third (list 1 (list 2 (list 3 (list 4 (list 5 (list 6 7))))))) -------------------------------------------------------------------------------- /code/Chapter 2/e2-26: -------------------------------------------------------------------------------- 1 | (define x (list 1 2 3)) 2 | (define y (list 4 5 6)) 3 | 4 | ; answer: 5 | ; (1 2 3 4 5 6) 6 | ; ((1 2 3) 4 5 6) 7 | ; ((1 2 3) (4 5 6)) 8 | 9 | (append x y) 10 | (cons x y) 11 | (list x y) -------------------------------------------------------------------------------- /code/Chapter 2/e2-27: -------------------------------------------------------------------------------- 1 | (define (reverse a) 2 | (if (null? a) 3 | '() 4 | (append (reverse (cdr a)) (list (car a))) 5 | ) 6 | ) 7 | 8 | (define (deep-reverse a) 9 | (if (null? a) 10 | '() 11 | (append (deep-reverse (cdr a)) ( 12 | if (pair? (car a)) 13 | (list (reverse (car a))) 14 | (list (car a)) 15 | ) 16 | ) 17 | ) 18 | ) 19 | 20 | 21 | (define x (list (list 1 2) (list 3 4))) 22 | 23 | (reverse x) 24 | 25 | (deep-reverse x) -------------------------------------------------------------------------------- /code/Chapter 2/e2-28: -------------------------------------------------------------------------------- 1 | (define (fringe items) 2 | (cond ((null? items) '()) 3 | ((pair? (car items)) (append (fringe (car items)) (fringe (cdr items)))) 4 | (else (cons (car items) (fringe (cdr items)))) 5 | 6 | ) 7 | ) 8 | 9 | (define x (list (list 1 2) (list 3 4))) 10 | 11 | (fringe x) 12 | 13 | (fringe (list x x)) 14 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-29: -------------------------------------------------------------------------------- 1 | (define (make-mobile left right) (list left right)) 2 | (define (make-branch length structure) (list length structure)) 3 | 4 | ; 5 | 6 | (define (left-branch mobile) 7 | (car mobile) 8 | ) 9 | (define (right-branch mobile) 10 | (car (cdr mobile)) 11 | ) 12 | (define (branch-length branch) 13 | (car branch) 14 | ) 15 | (define (branch-structure branch) 16 | (car (cdr branch)) 17 | ) 18 | 19 | ; 20 | 21 | (define (total-weight mobile) 22 | (let ( 23 | (leftbranch (left-branch mobile)) 24 | (rightbranch (right-branch mobile)) 25 | ) 26 | ( + 27 | ( 28 | if (pair? (branch-structure leftbranch)) 29 | (total-weight (branch-structure leftbranch)) 30 | (branch-structure leftbranch) 31 | ) 32 | ( 33 | if (pair? (branch-structure rightbranch)) 34 | (total-weight (branch-structure rightbranch)) 35 | (branch-structure rightbranch) 36 | ) 37 | ) 38 | ) 39 | ) 40 | 41 | (total-weight (make-mobile 42 | (make-branch 2 (make-mobile (make-branch 1 3) (make-branch 1 4))) 43 | (make-branch 2 (make-mobile (make-branch 1 5) (make-branch 1 6))) 44 | ) 45 | ) 46 | 47 | ; 48 | 49 | (define (balanced? mobile) 50 | (let ( 51 | (leftbranch (left-branch mobile)) 52 | (rightbranch (right-branch mobile)) 53 | ) 54 | (and 55 | ( = 56 | ( 57 | if (pair? (branch-structure leftbranch)) 58 | (* (total-weight (branch-structure leftbranch)) (branch-length leftbranch)) 59 | (* (branch-structure leftbranch) (branch-length leftbranch)) 60 | ) 61 | ( 62 | if (pair? (branch-structure rightbranch)) 63 | (* (total-weight (branch-structure rightbranch)) (branch-length rightbranch)) 64 | (* (branch-structure rightbranch) (branch-length rightbranch)) 65 | ) 66 | ) 67 | (if (pair? (branch-structure leftbranch)) (balanced? (branch-structure leftbranch)) true) 68 | (if (pair? (branch-structure rightbranch)) (balanced? (branch-structure rightbranch)) true) 69 | ) 70 | ) 71 | ) 72 | 73 | (balanced? (make-mobile 74 | (make-branch 2 (make-mobile (make-branch 1 6) (make-branch 2 3))) 75 | (make-branch 9 (make-mobile (make-branch 3 1) (make-branch 3 1))) 76 | ) 77 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-29d: -------------------------------------------------------------------------------- 1 | (define (make-mobile left right) (cons left right)) 2 | (define (make-branch length structure) 3 | (cons length structure)) 4 | 5 | ; 6 | 7 | (define (left-branch mobile) 8 | (car mobile) 9 | ) 10 | (define (right-branch mobile) 11 | (cdr mobile) 12 | ) 13 | (define (branch-length branch) 14 | (car branch) 15 | ) 16 | (define (branch-structure branch) 17 | (cdr branch) 18 | ) 19 | 20 | ; 21 | 22 | (define (total-weight mobile) 23 | (let ( 24 | (leftbranch (left-branch mobile)) 25 | (rightbranch (right-branch mobile)) 26 | ) 27 | (display leftbranch) 28 | (newline) 29 | (display rightbranch) 30 | ( + 31 | ( 32 | if (pair? (branch-structure leftbranch)) 33 | (total-weight (branch-structure leftbranch)) 34 | (branch-structure leftbranch) 35 | ) 36 | ( 37 | if (pair? (branch-structure rightbranch)) 38 | (total-weight (branch-structure rightbranch)) 39 | (branch-structure rightbranch) 40 | ) 41 | ) 42 | ) 43 | ) 44 | 45 | (total-weight (make-mobile 46 | (make-branch 2 (make-mobile (make-branch 1 3) (make-branch 1 4))) 47 | (make-branch 2 (make-mobile (make-branch 1 5) (make-branch 1 6))) 48 | ) 49 | ) 50 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-3: -------------------------------------------------------------------------------- 1 | (define (print-point p) 2 | (newline) 3 | (display "(") 4 | (display (x-point p)) 5 | (display ",") 6 | (display (y-point p)) 7 | (display ")") 8 | ) 9 | (define (start-segment line) 10 | (car line) 11 | ) 12 | (define (end-segment line) 13 | (cdr line) 14 | ) 15 | (define (make-segment start-point end-point) 16 | (cons start-point end-point) 17 | ) 18 | (define (x-point point) 19 | (car point) 20 | ) 21 | (define (y-point point) 22 | (cdr point) 23 | ) 24 | (define (make-point x y) 25 | (cons x y) 26 | ) 27 | (define (midpoint-segment line) 28 | (make-point 29 | (/ (+ (x-point (start-segment line)) (x-point (end-segment line))) 2) 30 | (/ (+ (y-point (start-segment line)) (y-point (end-segment line))) 2) 31 | ) 32 | ) 33 | 34 | ; copy from last exercise 35 | 36 | (define (make-rect left-top-point right-bottom-point) 37 | (cons left-top-point right-bottom-point) 38 | ) 39 | (define (one-line rect) 40 | (abs (- (x-point (car rect)) (x-point (cdr rect)))) 41 | ) 42 | (define (another-line rect) 43 | (abs (- (y-point (car rect)) (y-point (cdr rect)))) 44 | ) 45 | (define (cal-p rect) 46 | (* (+ (one-line rect) (another-line rect)) 2) 47 | ) 48 | (define (cal-a rect) 49 | (* (one-line rect) (another-line rect)) 50 | ) 51 | (cal-p (make-rect (make-point 1 4) (make-point 2 7))) 52 | (cal-a (make-rect (make-point 1 4) (make-point 2 7))) -------------------------------------------------------------------------------- /code/Chapter 2/e2-30: -------------------------------------------------------------------------------- 1 | (define (scale-tree tree factor) 2 | (display tree) 3 | (newline) 4 | (cond ((null? tree) '()) 5 | ((not (pair? tree)) (* tree factor)) 6 | (else (cons (scale-tree (car tree) factor) 7 | (scale-tree (cdr tree) factor))))) 8 | (scale-tree (list 2 (list 3 4)) 10) 9 | 10 | ; equals to (cons 20 (cons (cons 30 (cons 40 '())) '())) -------------------------------------------------------------------------------- /code/Chapter 2/e2-30-true: -------------------------------------------------------------------------------- 1 | (define (square-tree tree) 2 | (cond ((null? tree) '()) 3 | ((not (pair? tree)) (* tree tree)) 4 | (else (cons (square-tree (car tree)) (square-tree (cdr tree)))) 5 | ) 6 | ) 7 | 8 | 9 | (square-tree 10 | (list 1 11 | (list 2 (list 3 4) 5) 12 | (list 6 7) 13 | ) 14 | ) 15 | 16 | ; direct implement 17 | 18 | (define (square-tree-map tree) 19 | (map 20 | (lambda (x) 21 | (if (pair? x) 22 | (square-tree-map x) 23 | (square x) 24 | ) 25 | ) 26 | tree) 27 | ) 28 | 29 | (square-tree-map 30 | (list 1 31 | (list 2 (list 3 4) 5) 32 | (list 6 7) 33 | ) 34 | ) 35 | 36 | ; implement with map 37 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-31: -------------------------------------------------------------------------------- 1 | (define (tree-map term tree) 2 | (map 3 | (lambda (x) 4 | (if (pair? x) 5 | (tree-map term x) 6 | (term x) 7 | ) 8 | ) 9 | tree) 10 | ) 11 | 12 | (define (square-tree tree) (tree-map square tree)) 13 | 14 | (square-tree 15 | (list 1 16 | (list 2 (list 3 4) 5) 17 | (list 6 7) 18 | ) 19 | ) 20 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-32: -------------------------------------------------------------------------------- 1 | (define (subsets s) 2 | (if (null? s) 3 | (list '()) 4 | (let ((rest (subsets (cdr s)))) 5 | (append rest (map 6 | (lambda (x) 7 | (cons (car s) x) 8 | ) 9 | rest))) 10 | ) 11 | ) 12 | 13 | (subsets (list 2 3)) 14 | 15 | ; explain: recursive find subsets, combine all subsets of cdr set to the first element, then append to rest, thus generate all subsets of whole set -------------------------------------------------------------------------------- /code/Chapter 2/e2-33: -------------------------------------------------------------------------------- 1 | (define (map p sequence) 2 | (accumulate (lambda (x y) (cons x (p y))) nil sequence)) 3 | (define (append seq1 seq2) (accumulate cons seq1 seq2)) 4 | (define (length sequence) (accumulate inc 0 sequence)) -------------------------------------------------------------------------------- /code/Chapter 2/e2-34: -------------------------------------------------------------------------------- 1 | (define (accumulate op initial sequence) 2 | (if (null? sequence) 3 | initial 4 | (op (car sequence) 5 | (accumulate op initial (cdr sequence)) 6 | ) 7 | ) 8 | ) 9 | 10 | (define (horner-eval x coefficient-sequence) 11 | (accumulate 12 | (lambda (this-coeff higher-terms) 13 | (+ this-coeff (* higher-terms x)) 14 | ) 15 | 0 16 | coefficient-sequence 17 | ) 18 | ) 19 | 20 | (horner-eval 2 (list 1 3 0 5 0 1)) -------------------------------------------------------------------------------- /code/Chapter 2/e2-35: -------------------------------------------------------------------------------- 1 | (define (accumulate op initial sequence) 2 | (if (null? sequence) 3 | initial 4 | (op (car sequence) 5 | (accumulate op initial (cdr sequence)) 6 | ) 7 | ) 8 | ) 9 | 10 | (define (enumerate-tree tree) 11 | (cond ((null? tree) '()) 12 | ((not (pair? tree)) (list 1)) 13 | (else (append (enumerate-tree (car tree)) 14 | (enumerate-tree (cdr tree))))) 15 | ) 16 | 17 | (define (count-leaves t) 18 | (accumulate + 0 (map (lambda (x) x) (enumerate-tree t))) 19 | ) 20 | 21 | (define x (cons (list 1 2) (list 3 4))) 22 | 23 | (count-leaves x) -------------------------------------------------------------------------------- /code/Chapter 2/e2-36: -------------------------------------------------------------------------------- 1 | (define (accumulate op initial sequence) 2 | (if (null? sequence) 3 | initial 4 | (op (car sequence) 5 | (accumulate op initial (cdr sequence)) 6 | ) 7 | ) 8 | ) 9 | 10 | (define (get-first-elements seqs) 11 | (if (null? seqs) 12 | '() 13 | (cons (car (car seqs)) (get-first-elements (cdr seqs))) 14 | ) 15 | ) 16 | 17 | (define (get-cdr-elements seqs) 18 | (if (null? seqs) 19 | '() 20 | (cons (cdr (car seqs)) (get-cdr-elements (cdr seqs))) 21 | ) 22 | ) 23 | 24 | (define (accumulate-n op init seqs) 25 | (if (null? (car seqs)) 26 | '() 27 | (cons (accumulate op init (get-first-elements seqs)) 28 | (accumulate-n op init (get-cdr-elements seqs)) 29 | ) 30 | ) 31 | ) 32 | 33 | (accumulate-n + 0 (list (list 1 2 3) (list 4 5 6) (list 7 8 9) (list 10 11 12))) -------------------------------------------------------------------------------- /code/Chapter 2/e2-37: -------------------------------------------------------------------------------- 1 | (define (accumulate op initial sequence) 2 | (if (null? sequence) 3 | initial 4 | (op (car sequence) 5 | (accumulate op initial (cdr sequence)) 6 | ) 7 | ) 8 | ) 9 | 10 | (define (get-first-elements seqs) 11 | (if (null? seqs) 12 | '() 13 | (cons (car (car seqs)) (get-first-elements (cdr seqs))) 14 | ) 15 | ) 16 | 17 | (define (get-cdr-elements seqs) 18 | (if (null? seqs) 19 | '() 20 | (cons (cdr (car seqs)) (get-cdr-elements (cdr seqs))) 21 | ) 22 | ) 23 | 24 | (define (accumulate-n op init seqs) 25 | (if (null? (car seqs)) 26 | '() 27 | (cons (accumulate op init (get-first-elements seqs)) 28 | (accumulate-n op init (get-cdr-elements seqs)) 29 | ) 30 | ) 31 | ) 32 | 33 | ; above are utils 34 | 35 | (define (dot-product v w) 36 | (accumulate + 0 (map * v w)) 37 | ) 38 | (define (matrix-*-vector m v) 39 | (map (lambda (t) 40 | (dot-product t v) 41 | ) m) 42 | ) 43 | (define (transpose mat) 44 | (accumulate-n cons '() mat) 45 | ) 46 | (define (matrix-*-matrix m n) 47 | (let ((cols (transpose n))) 48 | (map (lambda (t) (matrix-*-vector cols t)) m) 49 | ) 50 | ) 51 | 52 | (define (v1) (list 1 2 3)) 53 | (define (m1) (list (list 1 2 3) (list 2 3 4))) 54 | (define (n1) (transpose (m1))) 55 | (display (matrix-*-vector (m1) (v1))) 56 | (display (matrix-*-matrix (m1) (n1))) -------------------------------------------------------------------------------- /code/Chapter 2/e2-38: -------------------------------------------------------------------------------- 1 | (define (fold-left op initial sequence) (define (iter result rest) 2 | (if (null? rest) result 3 | (iter (op result (car rest)) 4 | (cdr rest)))) 5 | (iter initial sequence)) 6 | (fold-left / 1 (list 1 2 3)) 7 | (fold-left list '() (list 1 2 3)) 8 | 9 | ; property: (op a b) should equal to (op b a) -------------------------------------------------------------------------------- /code/Chapter 2/e2-39: -------------------------------------------------------------------------------- 1 | (define (fold-right op initial sequence) 2 | (if (null? sequence) 3 | initial 4 | (op (car sequence) 5 | (fold-right op initial (cdr sequence)) 6 | ) 7 | ) 8 | ) 9 | (define (fold-left op initial sequence) (define (iter result rest) 10 | (if (null? rest) result 11 | (iter (op result (car rest)) 12 | (cdr rest)))) 13 | (iter initial sequence)) 14 | 15 | ; above are utils 16 | 17 | (define (reverse sequence) 18 | (fold-right (lambda (x y) (append y (list x))) '() sequence)) 19 | (define (reverse-2 sequence) 20 | (fold-left (lambda (x y) (cons y x)) '() sequence)) 21 | 22 | (reverse (list 1 2 3 4 5)) 23 | (reverse-2 (list 1 2 3 4 5)) 24 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-4: -------------------------------------------------------------------------------- 1 | (define (cons x y) (lambda (m) (m x y))) 2 | (define (car z) 3 | (z (lambda (p q) p))) 4 | (define (cdr z) 5 | (z (lambda (p q) q))) 6 | 7 | (car (cons 1 3)) 8 | (cdr (cons 1 3)) -------------------------------------------------------------------------------- /code/Chapter 2/e2-40: -------------------------------------------------------------------------------- 1 | (define (unique-pairs n) 2 | (flatmap (lambda (i) 3 | (map (lambda (j) (list i j)) (enumerate-interval 1 (- i 1)))) 4 | (enumerate-interval 1 n)) 5 | ) 6 | 7 | (define (prime-sum-pairs n) (map make-pair-sum 8 | (filter prime-sum? (unique-pairs n)))) 9 | 10 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-41: -------------------------------------------------------------------------------- 1 | (define (flatmap proc seq) 2 | (accumulate append '() (map proc seq)) 3 | ) 4 | (define (accumulate op initial sequence) 5 | (if (null? sequence) 6 | initial 7 | (op (car sequence) 8 | (accumulate op initial (cdr sequence)) 9 | ) 10 | ) 11 | ) 12 | (define (enumerate-interval low high) (if (> low high) 13 | '() 14 | (cons low (enumerate-interval (+ low 1) high)))) 15 | 16 | ; above are utils 17 | 18 | (define (get-seq n) 19 | (enumerate-interval 1 n) 20 | ) 21 | 22 | (define (all-pairs n) 23 | (flatmap (lambda(b) (map (lambda(c) (list b c)) (get-seq (- b 1)))) (get-seq n)) 24 | ) 25 | 26 | (define (all-triple n) 27 | (flatmap (lambda (a) (map (lambda(pair) (cons a pair)) (all-pairs (- a 1)))) (get-seq n)) 28 | ) 29 | 30 | (define (find-triple n s) 31 | (filter 32 | (lambda (triple) 33 | (= s 34 | (+ (car triple) (cadr triple) (caddr triple)) 35 | ) 36 | ) 37 | (all-triple n) 38 | ) 39 | ) 40 | (find-triple 5 8) -------------------------------------------------------------------------------- /code/Chapter 2/e2-44: -------------------------------------------------------------------------------- 1 | (define (up-split painter n) (if (= n 0) 2 | painter 3 | (let ((smaller (up-split painter (- n 1)))) 4 | (below painter (beside smaller smaller))))) -------------------------------------------------------------------------------- /code/Chapter 2/e2-45: -------------------------------------------------------------------------------- 1 | (define (split painter first second) 2 | (let 3 | ((smaller (split painter first second))) 4 | (first painter (second smaller smaller)) 5 | ) 6 | ) 7 | 8 | (define up-split (split below beside)) 9 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-46: -------------------------------------------------------------------------------- 1 | (define (make-vect x y) 2 | (cons x y) 3 | ) 4 | 5 | (define (xcor-vect v) 6 | (car v) 7 | ) 8 | 9 | (define (ycor-vect v) 10 | (cdr v) 11 | ) 12 | 13 | (define (add-vect v1 v2) 14 | (make-vect (+ (xcor-vect v1) (xcor-vect v2)) (+ (ycor-vect v1) (ycor-vect v2))) 15 | ) 16 | 17 | (define (sub-vect v1 v2) 18 | (make-vect (- (xcor-vect v1) (xcor-vect v2)) (- (ycor-vect v1) (ycor-vect v2))) 19 | ) 20 | 21 | (define (scale-vect s v) 22 | (make-vect (* s (xcor-vect v)) (* s (ycor-vect v))) 23 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-47: -------------------------------------------------------------------------------- 1 | (define (origin-frame frame) 2 | (car frame) 3 | ) 4 | 5 | (define (edge1-frame frame) 6 | (cadr frame) 7 | ) 8 | 9 | (define (edge2-frame) 10 | (caddr frame) 11 | ) 12 | 13 | ; first implemention 14 | 15 | (define (origin-frame frame) 16 | (car frame) 17 | ) 18 | 19 | (define (edge1-frame frame) 20 | (cadr frame) 21 | ) 22 | 23 | (define (edge2-frame) 24 | (cddr frame) 25 | ) 26 | 27 | ; second implemention -------------------------------------------------------------------------------- /code/Chapter 2/e2-48: -------------------------------------------------------------------------------- 1 | (define (make-segment v1 v2) 2 | (cons v1 v2) 3 | ) 4 | 5 | (define (start-segment segment) 6 | (car segment) 7 | ) 8 | 9 | (define (end-segment segmeng) 10 | (cdr segment) 11 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-49: -------------------------------------------------------------------------------- 1 | (define (top-line) 2 | (make-segment (make-vect 0 0) (make-vect 0 1)) 3 | ) 4 | (define (right-line) 5 | (make-segment (make-vect 0 1) (make-vect 1 1)) 6 | ) 7 | (define (bottom-line) 8 | (make-segment (make-vect 1 1) (make-vect 1 0)) 9 | ) 10 | (define (left-line) 11 | (make-segment (make-vect 1 0) (make-vect 0 0)) 12 | ) 13 | 14 | (segments->painter (list (top-line) (right-line) (bottom-line) (left-line))) 15 | 16 | ; outline 17 | 18 | (define (first-line) 19 | (make-segment (make-vect 0 0) (make-vect 1 1)) 20 | ) 21 | (define (second-line) 22 | (make-segment (make-vect 0 1) (make-vect 1 0)) 23 | ) 24 | 25 | (segments->painter (list (first-line) (second-line))) 26 | 27 | ; X 28 | 29 | (define (top-line) 30 | (make-segment (make-vect 0 0.5) (make-vect 0.5 0)) 31 | ) 32 | (define (right-line) 33 | (make-segment (make-vect 0.5 0) (make-vect 1 0.5)) 34 | ) 35 | (define (bottom-line) 36 | (make-segment (make-vect 1 0.5) (make-vect 0.5 1)) 37 | ) 38 | (define (left-line) 39 | (make-segment (make-vect 0.5 1) (make-vect 0 0.5)) 40 | ) 41 | 42 | (segments->painter (list (top-line) (right-line) (bottom-line) (left-line))) 43 | 44 | ; diamond 45 | 46 | ; wave......fuck off -------------------------------------------------------------------------------- /code/Chapter 2/e2-5: -------------------------------------------------------------------------------- 1 | 没看懂题 -------------------------------------------------------------------------------- /code/Chapter 2/e2-50: -------------------------------------------------------------------------------- 1 | (define (flip-horiz painter) 2 | (transform-painter painter (make-vect 1 0) (make-vect 0 0) (make-vect 1 1)) 3 | ) 4 | (define (degree180 painter) 5 | (transform-painter painter (make-vect 1 1) (make-vect 0 1) (make-vect 1 0)) 6 | ) 7 | (define (degree270 painter) 8 | (transform-painter painter (make-vect 0 1) (make-vect 0 0) (make-vect 1 1)) 9 | ) 10 | 11 | (degree180 (flip-horiz painter)) 12 | (degree270 (flip-horiz painter)) -------------------------------------------------------------------------------- /code/Chapter 2/e2-51: -------------------------------------------------------------------------------- 1 | (define (below painter1 painter2) 2 | (let ((split-point (make-vect 0 0.5))) 3 | (let ((paint-left (transform-painter 4 | painter1 5 | (make-vect 0.0 0.0) 6 | (make-vect 0.0 1.0) 7 | split-point)) 8 | (paint-right 9 | (transform-painter 10 | painter2 11 | split-point 12 | (make-vect 1.0 0.5) 13 | (make-vect 0 1.0)))) 14 | (lambda (frame) (paint-left frame) (paint-right frame)) 15 | ))) 16 | 17 | ; first version 18 | 19 | (define (degree90 painter) 20 | (transform-painter painter (make-vect 1 0) (make-vect 1 1) (make-vect 0 0)) 21 | ) 22 | 23 | (define (below painter1 painter2) 24 | (degree90 (beside painter1 painter2)) 25 | ) 26 | 27 | ; second version -------------------------------------------------------------------------------- /code/Chapter 2/e2-52: -------------------------------------------------------------------------------- 1 | ; ignore question a 2 | 3 | (define (corner-split painter n) (if (= n 0) 4 | painter 5 | (let ((up (up-split painter (- n 1))) 6 | (right (right-split painter (- n 1)))) 7 | (let ( 8 | (corner (corner-split painter (- n 1)))) 9 | (beside (below painter up) 10 | (below right corner)))))) 11 | 12 | ; question b 13 | 14 | (define (square-limit painter n) 15 | (let ((combine4 (square-of-four identity flip-horiz 16 | flip-vert rotate180))) 17 | (combine4 (corner-split painter n)))) 18 | 19 | ; question c -------------------------------------------------------------------------------- /code/Chapter 2/e2-54: -------------------------------------------------------------------------------- 1 | (define (equal? l1 l2) 2 | (cond 3 | ((and (null? l1) (null? l2)) true) 4 | ((eq? (car l1) (car l2)) (equal? (cdr l1) (cdr l2))) 5 | ((not (eq? (car l1) (car l2))) false) 6 | (else false) 7 | ) 8 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-56: -------------------------------------------------------------------------------- 1 | (define (exponentiation? x) (and (pair? x) (eq? (car x) '**))) 2 | (define (base x) (cadr x)) 3 | (define (exponent x) (caddr x)) 4 | (define (make-exponentiation base exponent) 5 | (cond 6 | ((=number? exponent 0) 1) 7 | ((=number? exponent 1) base) 8 | (else (list '** base exponent)) 9 | ) 10 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-57: -------------------------------------------------------------------------------- 1 | (define (augend s) 2 | (if (null? (cdddr s)) 3 | (caddr s) 4 | (cons '+ (cddr s)) 5 | ) 6 | ) 7 | 8 | (define (multiplicand p) 9 | (if (null? (cdddr p)) 10 | (caddr p) 11 | (cons '* (cddr p)) 12 | ) 13 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-58: -------------------------------------------------------------------------------- 1 | (define (sum? x) (and (pair? x) (eq? (cadr x) '+))) 2 | (define (addend s) (car s)) 3 | (define (augend s) (caddr s)) 4 | 5 | 6 | (define (product? x) (and (pair? x) (eq? (cadr x) '*))) 7 | (define (multiplier p) (car p)) 8 | (define (multiplicand p) (caddr p)) 9 | 10 | 11 | ; question a 12 | 13 | (define (has* x) 14 | (memq '* x) 15 | ) 16 | 17 | (define (has+ x) 18 | (memq '+ x) 19 | ) 20 | 21 | (define (get+ x) 22 | (define (iter result x) 23 | (if (= (car x) '+) 24 | result 25 | (iter (append result (list (car x))) (cdr x)) 26 | ) 27 | ) 28 | (iter '() x) 29 | ) 30 | 31 | (define (get* x) 32 | (define (iter result x) 33 | (if (= (car x) '*) 34 | result 35 | (iter (append result (list (car x))) (cdr x)) 36 | ) 37 | ) 38 | (iter '() x) 39 | ) 40 | 41 | (define (sum? x) (and (pair? x) (not (has* x)) (has+ x))) 42 | (define (addend s) (get+ s)) 43 | (define (augend s) (has+ s)) 44 | 45 | 46 | (define (product? x) (and (pair? x) (has* x))) 47 | (define (multiplier p) (get* x)) 48 | (define (multiplicand p) (has* x)) 49 | 50 | ; question b -------------------------------------------------------------------------------- /code/Chapter 2/e2-59: -------------------------------------------------------------------------------- 1 | (define (union-set set1 set2) 2 | (cond 3 | ((null? set1) set2) 4 | ((null? set2) set1) 5 | ((element-of-set? (car set1) set2) 6 | (union-set (cdr set1) set2) 7 | (else (cons (car set1) (union-set (cdr set1) set2)))))) -------------------------------------------------------------------------------- /code/Chapter 2/e2-6: -------------------------------------------------------------------------------- 1 | (define zero (lambda (f) (lambda (x) x))) 2 | (define (add-1 n) 3 | (lambda (f) (lambda (x) (f ((n f) x))))) 4 | 5 | (define one (lambda (f) (lambda (x) (f x)))) 6 | (define two (lambda (f) (lambda (x) (f (f x))))) 7 | (define (+ a b) 8 | (lambda (f) (lambda (x) ((a f) ((b f) x)))) 9 | ) 10 | 11 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-60: -------------------------------------------------------------------------------- 1 | (define (element-of-set? x set) (cond ((null? set) false) 2 | ((equal? x (car set)) true) 3 | (else (element-of-set? x (cdr set))))) 4 | 5 | (define (adjoin-set x set) 6 | (cons x set)) 7 | 8 | (define (intersection-set set1 set2) 9 | (cond ((or (null? set1) (null? set2)) '()) 10 | ((element-of-set? (car set1) set2) 11 | (cons (car set1) (intersection-set (cdr set1) set2))) 12 | (else (intersection-set (cdr set1) set2)))) 13 | 14 | (define (union-set set1 set2) 15 | (append set1 set1) 16 | ) 17 | 18 | ; adjoin-set and union-set will be faster, element-of-set won't change, intersection-set will be slower 19 | ; so if your application need faster add and union, you can choose this version, otherwise choose normal version -------------------------------------------------------------------------------- /code/Chapter 2/e2-61: -------------------------------------------------------------------------------- 1 | (define (adjoin-set x set) 2 | (cond 3 | ((null? set) (list x)) 4 | ((= x (car set)) set) 5 | ((< x (car set)) (cons x set)) 6 | (else (cons (car set) (adjoin-set x (cdr set)))) 7 | ) 8 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-62: -------------------------------------------------------------------------------- 1 | (define (union-set set1 set2) 2 | (cond 3 | ((null? set1) set2) 4 | ((null? set2) set1) 5 | (let ((x1 (car set1)) (x2 (car set2))) 6 | ((= x1 x2) (cons x1 (union-set (cdr set1) (cdr set2)))) 7 | ((< x1 x2) (cons x1 (cons x2 (union-set (cdr set1) (cdr set2))))) 8 | (else (cons x2 (cons x1 (union-set (cdr set1) (cdr set2))))) 9 | ) 10 | ) 11 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-63: -------------------------------------------------------------------------------- 1 | (define (entry tree) (car tree)) 2 | (define (left-branch tree) (cadr tree)) 3 | (define (right-branch tree) (caddr tree)) 4 | (define (make-tree entry left right) 5 | (list entry left right)) 6 | 7 | (define (tree->list-1 tree) (if (null? tree) '() 8 | (append (tree->list-1 (left-branch tree)) 9 | (cons (entry tree) 10 | (tree->list-1 11 | (right-branch tree)))))) 12 | 13 | (define (tree->list-2 tree) 14 | (define (copy-to-list tree result-list) (if (null? tree) 15 | result-list 16 | (copy-to-list (left-branch tree) 17 | (cons (entry tree) 18 | (copy-to-list 19 | (right-branch tree) 20 | result-list))))) 21 | (copy-to-list tree '())) 22 | 23 | (tree->list-1 '(7 (3 (1 () ()) (5 () ())) (9 () (11 () ())))) 24 | (tree->list-2 '(7 (3 (1 () ()) (5 () ())) (9 () (11 () ())))) 25 | 26 | ; results are same 27 | ; same steps, just different order. first one first calculate left branch then right branch, second one first calculate right branch then left branch. -------------------------------------------------------------------------------- /code/Chapter 2/e2-64: -------------------------------------------------------------------------------- 1 | ; explain: 2 | ; 1. calculate left branch size use (n - 1) / 2 3 | ; 2. use left branch size to build left tree 4 | ; 3. use first elements of remain elements(after building left tree) as entry 5 | ; 4. calculate right branch size use (n - left-size - 1) 6 | ; 5. use remain elements and right branch size to build right tree 7 | ; 6. make tree with (entry left-tree right-tree) 8 | ; 7. construct tree with remain elements and return 9 | 10 | ; O(n) -------------------------------------------------------------------------------- /code/Chapter 2/e2-65: -------------------------------------------------------------------------------- 1 | (define (union-set tree1 tree2) 2 | (let ((templist1 (tree->list-1 tree1)) (templist2 (tree->list-1 tree2))) 3 | (list->tree (union-list templist1 templist2)) 4 | ) 5 | ) 6 | 7 | (define (intersection-set tree1 tree2) 8 | (let ((templist1 (tree->list-1 tree1)) (templist2 (tree->list-1 tree2))) 9 | (list->tree (intersection-list templist1 templist2)) 10 | ) 11 | ) 12 | 13 | ; ignore implements of union-list and intersection, you can find it in previous sections, easy 14 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-66: -------------------------------------------------------------------------------- 1 | (define (lookup given-key set-of-records) 2 | (cond 3 | ((null? set-of-records) false) 4 | ((= given-key (key (car set-of-records))) (car set-of-records)) 5 | ((< given-key (key (car set-of-records))) (lookup given-key (cadr set-of-records))) 6 | ((> given-key (key (car set-of-records))) (lookup given-key (caddr set-of-records))) 7 | ) 8 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-67: -------------------------------------------------------------------------------- 1 | 2 | (define (make-leaf symbol weight) (list 'leaf symbol weight)) (define (leaf? object) (eq? (car object) 'leaf)) 3 | (define (symbol-leaf x) (cadr x)) 4 | (define (weight-leaf x) (caddr x)) 5 | 6 | (define (make-code-tree left right) (list left 7 | right 8 | (append (symbols left) (symbols right)) 9 | (+ (weight left) (weight right)))) 10 | 11 | (define (left-branch tree) (car tree)) (define (right-branch tree) (cadr tree)) (define (symbols tree) 12 | (if (leaf? tree) 13 | (list (symbol-leaf tree)) (caddr tree))) 14 | (define (weight tree) (if (leaf? tree) 15 | (weight-leaf tree) 16 | (cadddr tree))) 17 | 18 | (define (decode bits tree) 19 | (define (decode-1 bits current-branch) 20 | (if (null? bits) '() 21 | (let ((next-branch 22 | (choose-branch (car bits) current-branch))) 23 | (if (leaf? next-branch) 24 | (cons (symbol-leaf next-branch) 25 | (decode-1 (cdr bits) tree)) 26 | (decode-1 (cdr bits) next-branch))))) 27 | (decode-1 bits tree)) 28 | 29 | (define (choose-branch bit branch) 30 | (cond ((= bit 0) (left-branch branch)) 31 | ((= bit 1) (right-branch branch)) 32 | (else (error "bad bit: CHOOSE-BRANCH" bit)))) 33 | 34 | (define sample-tree (make-code-tree (make-leaf 'A 4) 35 | (make-code-tree 36 | (make-leaf 'B 2) 37 | (make-code-tree 38 | (make-leaf 'D 1) 39 | (make-leaf 'C 1))))) 40 | (define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0)) 41 | (decode sample-message sample-tree) 42 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-68: -------------------------------------------------------------------------------- 1 | (define (make-leaf symbol weight) (list 'leaf symbol weight)) (define (leaf? object) (eq? (car object) 'leaf)) 2 | (define (symbol-leaf x) (cadr x)) 3 | (define (weight-leaf x) (caddr x)) 4 | 5 | (define (make-code-tree left right) (list left 6 | right 7 | (append (symbols left) (symbols right)) 8 | (+ (weight left) (weight right)))) 9 | 10 | (define (left-branch tree) (car tree)) (define (right-branch tree) (cadr tree)) (define (symbols tree) 11 | (if (leaf? tree) 12 | (list (symbol-leaf tree)) (caddr tree))) 13 | (define (weight tree) (if (leaf? tree) 14 | (weight-leaf tree) 15 | (cadddr tree))) 16 | 17 | (define (decode bits tree) 18 | (define (decode-1 bits current-branch) 19 | (if (null? bits) '() 20 | (let ((next-branch 21 | (choose-branch (car bits) current-branch))) 22 | (if (leaf? next-branch) 23 | (cons (symbol-leaf next-branch) 24 | (decode-1 (cdr bits) tree)) 25 | (decode-1 (cdr bits) next-branch))))) 26 | (decode-1 bits tree)) 27 | 28 | (define (choose-branch bit branch) 29 | (cond ((= bit 0) (left-branch branch)) 30 | ((= bit 1) (right-branch branch)) 31 | (else (error "bad bit: CHOOSE-BRANCH" bit)))) 32 | 33 | (define sample-tree (make-code-tree (make-leaf 'A 4) 34 | (make-code-tree 35 | (make-leaf 'B 2) 36 | (make-code-tree 37 | (make-leaf 'D 1) 38 | (make-leaf 'C 1))))) 39 | 40 | ; utils 41 | 42 | (define (encode-symbol char tree) 43 | (define (encode-1 bits char tree) 44 | (cond 45 | ((leaf? tree) (if (eqv? (symbol-leaf tree) char) bits (error "Failed to find that character!"))) 46 | ((memq char (symbols (left-branch tree))) (encode-1 (append bits (list '0)) char (left-branch tree))) 47 | ((memq char (symbols (right-branch tree))) (encode-1 (append bits (list '1)) char (right-branch tree))) 48 | (else (error "Failed to find that character!")) 49 | ) 50 | ) 51 | (encode-1 '() char tree) 52 | ) 53 | 54 | (define (encode message tree) (if (null? message) 55 | '() 56 | (append (encode-symbol (car message) tree) 57 | (encode (cdr message) tree)))) 58 | 59 | (encode '(a d a b b c a) sample-tree) 60 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-69: -------------------------------------------------------------------------------- 1 | (define (make-leaf symbol weight) (list 'leaf symbol weight)) (define (leaf? object) (eq? (car object) 'leaf)) 2 | (define (symbol-leaf x) (cadr x)) 3 | (define (weight-leaf x) (caddr x)) 4 | 5 | (define (make-code-tree left right) (list left 6 | right 7 | (append (symbols left) (symbols right)) 8 | (+ (weight left) (weight right)))) 9 | 10 | (define (left-branch tree) (car tree)) (define (right-branch tree) (cadr tree)) (define (symbols tree) 11 | (if (leaf? tree) 12 | (list (symbol-leaf tree)) (caddr tree))) 13 | (define (weight tree) (if (leaf? tree) 14 | (weight-leaf tree) 15 | (cadddr tree))) 16 | 17 | (define (decode bits tree) 18 | (define (decode-1 bits current-branch) 19 | (if (null? bits) '() 20 | (let ((next-branch 21 | (choose-branch (car bits) current-branch))) 22 | (if (leaf? next-branch) 23 | (cons (symbol-leaf next-branch) 24 | (decode-1 (cdr bits) tree)) 25 | (decode-1 (cdr bits) next-branch))))) 26 | (decode-1 bits tree)) 27 | 28 | (define (choose-branch bit branch) 29 | (cond ((= bit 0) (left-branch branch)) 30 | ((= bit 1) (right-branch branch)) 31 | (else (error "bad bit: CHOOSE-BRANCH" bit)))) 32 | 33 | (define (make-leaf-set pairs) (if (null? pairs) 34 | '() 35 | (let ((pair (car pairs))) 36 | (adjoin-set (make-leaf (car pair) 37 | (cadr pair)) 38 | (make-leaf-set (cdr pairs)))))) 39 | 40 | (define (adjoin-set x set) (cond ((null? set) (list x)) 41 | ((< (weight x) (weight (car set))) (cons x set)) 42 | (else (cons (car set) 43 | (adjoin-set x (cdr set)))))) 44 | 45 | ; dirty utils 46 | 47 | (define (successive-merge pairs) 48 | (if (null? (cdr pairs)) 49 | (car pairs) 50 | (successive-merge (adjoin-set (make-code-tree (car pairs) (cadr pairs)) (cddr pairs))) 51 | ) 52 | ) 53 | 54 | (define (generate-huffman-tree pairs) (successive-merge (make-leaf-set pairs))) 55 | 56 | (generate-huffman-tree '((A 4) (B 2) (C 1) (D 1))) 57 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-7: -------------------------------------------------------------------------------- 1 | (define (add-interval x y) 2 | (make-interval (+ (lower-bound x) (lower-bound y)) 3 | (+ (upper-bound x) (upper-bound y)))) 4 | 5 | (define (mul-interval x y) 6 | (let ((p1 (* (lower-bound x) (lower-bound y))) 7 | (p2 (* (lower-bound x) (upper-bound y))) 8 | (p3 (* (upper-bound x) (lower-bound y))) 9 | (p4 (* (upper-bound x) (upper-bound y)))) 10 | (make-interval (min p1 p2 p3 p4) 11 | (max p1 p2 p3 p4)))) 12 | 13 | (define (div-interval x y) 14 | (mul-interval 15 | x 16 | (make-interval (/ 1.0 (upper-bound y)) 17 | (/ 1.0 (lower-bound y))))) 18 | 19 | (define (make-interval a b) (cons a b)) 20 | 21 | (define (upper-bound x) 22 | (+ (car x) (* (car x)(cdr x))) 23 | ) 24 | 25 | (define (lower-bound x) 26 | (- (car x) (* (car x)(cdr x))) 27 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-70: -------------------------------------------------------------------------------- 1 | (define (make-leaf symbol weight) (list 'leaf symbol weight)) (define (leaf? object) (eq? (car object) 'leaf)) 2 | (define (symbol-leaf x) (cadr x)) 3 | (define (weight-leaf x) (caddr x)) 4 | 5 | (define (make-code-tree left right) (list left 6 | right 7 | (append (symbols left) (symbols right)) 8 | (+ (weight left) (weight right)))) 9 | 10 | (define (left-branch tree) (car tree)) (define (right-branch tree) (cadr tree)) (define (symbols tree) 11 | (if (leaf? tree) 12 | (list (symbol-leaf tree)) (caddr tree))) 13 | (define (weight tree) (if (leaf? tree) 14 | (weight-leaf tree) 15 | (cadddr tree))) 16 | 17 | (define (decode bits tree) 18 | (define (decode-1 bits current-branch) 19 | (if (null? bits) '() 20 | (let ((next-branch 21 | (choose-branch (car bits) current-branch))) 22 | (if (leaf? next-branch) 23 | (cons (symbol-leaf next-branch) 24 | (decode-1 (cdr bits) tree)) 25 | (decode-1 (cdr bits) next-branch))))) 26 | (decode-1 bits tree)) 27 | 28 | (define (choose-branch bit branch) 29 | (cond ((= bit 0) (left-branch branch)) 30 | ((= bit 1) (right-branch branch)) 31 | (else (error "bad bit: CHOOSE-BRANCH" bit)))) 32 | 33 | (define (make-leaf-set pairs) (if (null? pairs) 34 | '() 35 | (let ((pair (car pairs))) 36 | (adjoin-set (make-leaf (car pair) 37 | (cadr pair)) 38 | (make-leaf-set (cdr pairs)))))) 39 | 40 | (define (adjoin-set x set) (cond ((null? set) (list x)) 41 | ((< (weight x) (weight (car set))) (cons x set)) 42 | (else (cons (car set) 43 | (adjoin-set x (cdr set)))))) 44 | 45 | (define (encode-symbol char tree) 46 | (define (encode-1 bits char tree) 47 | (cond 48 | ((leaf? tree) (if (eqv? (symbol-leaf tree) char) bits (error "Failed to find that character!"))) 49 | ((memq char (symbols (left-branch tree))) (encode-1 (append bits (list '0)) char (left-branch tree))) 50 | ((memq char (symbols (right-branch tree))) (encode-1 (append bits (list '1)) char (right-branch tree))) 51 | (else (error "Failed to find that character!")) 52 | ) 53 | ) 54 | (encode-1 '() char tree) 55 | ) 56 | 57 | (define (encode message tree) (if (null? message) 58 | '() 59 | (append (encode-symbol (car message) tree) 60 | (encode (cdr message) tree)))) 61 | 62 | ; dirty utils 63 | 64 | (define (successive-merge pairs) 65 | (if (null? (cdr pairs)) 66 | (car pairs) 67 | (successive-merge (adjoin-set (make-code-tree (car pairs) (cadr pairs)) (cddr pairs))) 68 | ) 69 | ) 70 | 71 | (define (generate-huffman-tree pairs) (successive-merge (make-leaf-set pairs))) 72 | 73 | (define lyric-tree 74 | (generate-huffman-tree '((A 2) (GET 2) (SHA 3) (WAH 1) (BOOM 1) (JOB 2) (NA 16) (YIP 9))) 75 | ) 76 | 77 | (encode '(Get a job) lyric-tree) 78 | (encode '(Sha na na na na na na na na) lyric-tree) 79 | (encode '(Get a job) lyric-tree) 80 | (encode '(Sha na na na na na na na na) lyric-tree) 81 | (encode '(Wah yip yip yip yip yip yip yip yip yip) lyric-tree) 82 | (encode '(Sha boom) lyric-tree) 83 | 84 | ; need 84 bits 85 | 86 | ; fixed-length code: 8 status, code length is 3, so we need 3 x 36 = 108 bits -------------------------------------------------------------------------------- /code/Chapter 2/e2-71: -------------------------------------------------------------------------------- 1 | (define (make-leaf symbol weight) (list 'leaf symbol weight)) (define (leaf? object) (eq? (car object) 'leaf)) 2 | (define (symbol-leaf x) (cadr x)) 3 | (define (weight-leaf x) (caddr x)) 4 | 5 | (define (make-code-tree left right) (list left 6 | right 7 | (append (symbols left) (symbols right)) 8 | (+ (weight left) (weight right)))) 9 | 10 | (define (left-branch tree) (car tree)) (define (right-branch tree) (cadr tree)) (define (symbols tree) 11 | (if (leaf? tree) 12 | (list (symbol-leaf tree)) (caddr tree))) 13 | (define (weight tree) (if (leaf? tree) 14 | (weight-leaf tree) 15 | (cadddr tree))) 16 | 17 | (define (decode bits tree) 18 | (define (decode-1 bits current-branch) 19 | (if (null? bits) '() 20 | (let ((next-branch 21 | (choose-branch (car bits) current-branch))) 22 | (if (leaf? next-branch) 23 | (cons (symbol-leaf next-branch) 24 | (decode-1 (cdr bits) tree)) 25 | (decode-1 (cdr bits) next-branch))))) 26 | (decode-1 bits tree)) 27 | 28 | (define (choose-branch bit branch) 29 | (cond ((= bit 0) (left-branch branch)) 30 | ((= bit 1) (right-branch branch)) 31 | (else (error "bad bit: CHOOSE-BRANCH" bit)))) 32 | 33 | (define (make-leaf-set pairs) (if (null? pairs) 34 | '() 35 | (let ((pair (car pairs))) 36 | (adjoin-set (make-leaf (car pair) 37 | (cadr pair)) 38 | (make-leaf-set (cdr pairs)))))) 39 | 40 | (define (adjoin-set x set) (cond ((null? set) (list x)) 41 | ((< (weight x) (weight (car set))) (cons x set)) 42 | (else (cons (car set) 43 | (adjoin-set x (cdr set)))))) 44 | 45 | (define (encode-symbol char tree) 46 | (define (encode-1 bits char tree) 47 | (cond 48 | ((leaf? tree) (if (eqv? (symbol-leaf tree) char) bits (error "Failed to find that character!"))) 49 | ((memq char (symbols (left-branch tree))) (encode-1 (append bits (list '0)) char (left-branch tree))) 50 | ((memq char (symbols (right-branch tree))) (encode-1 (append bits (list '1)) char (right-branch tree))) 51 | (else (error "Failed to find that character!")) 52 | ) 53 | ) 54 | (encode-1 '() char tree) 55 | ) 56 | 57 | (define (encode message tree) (if (null? message) 58 | '() 59 | (append (encode-symbol (car message) tree) 60 | (encode (cdr message) tree)))) 61 | 62 | (define (successive-merge pairs) 63 | (if (null? (cdr pairs)) 64 | (car pairs) 65 | (successive-merge (adjoin-set (make-code-tree (car pairs) (cadr pairs)) (cddr pairs))) 66 | ) 67 | ) 68 | 69 | (define (generate-huffman-tree pairs) (successive-merge (make-leaf-set pairs))) 70 | 71 | ; dirty utils 72 | 73 | (define (generate-pair n) 74 | (if (= n 0) 75 | '() 76 | (cons (list n (expt 2 (- n 1))) (generate-pair (- n 1))) 77 | ) 78 | ) 79 | 80 | 81 | (define (n-tree n) 82 | (generate-huffman-tree (generate-pair n)) 83 | ) 84 | 85 | (display (n-tree 5)) 86 | (display (n-tree 10)) 87 | 88 | ; 1 bit need to encode the most frequent symbol 89 | 90 | ; n-1 bits need to encode the least frequent symbol 91 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-72: -------------------------------------------------------------------------------- 1 | ; O(1) to encode the most frequent symbol 2 | 3 | ; O(logn) to encode the least frequent symbol -------------------------------------------------------------------------------- /code/Chapter 2/e2-73: -------------------------------------------------------------------------------- 1 | ; a: 2 | ; first deal with number and variable 3 | ; then get data-directed procedure and apply to operands 4 | ; 5 | ; the reason is, number and variable don't have their own tag, they are primitive elements. 6 | 7 | ; b: 8 | 9 | (define deriv-sum 10 | (define (sum exp var) 11 | (make-sum (deriv (car exp) var) 12 | (deriv (cadr exp) var)) 13 | ) 14 | (put 'deriv '+ sum) 15 | ) 16 | 17 | (define deriv-product 18 | (define (product exp var) 19 | (make-sum 20 | (make-product (car exp) 21 | (deriv (cadr exp) var)) 22 | (make-product (deriv (car exp) var) 23 | (cadr exp))) 24 | ) 25 | (put 'deriv '* product) 26 | ) 27 | 28 | ; c: 29 | 30 | (define (make-exponentiation) 31 | (define (exp base exponent) 32 | (cond 33 | ((=number? exponent 0) 1) 34 | ((=number? exponent 1) base) 35 | (else (list '** base exponent)) 36 | )) 37 | (put 'exp '** exp) 38 | ) 39 | 40 | ; d: 41 | ; we need to swap the position of exp and var variable of two packages' install procedure -------------------------------------------------------------------------------- /code/Chapter 2/e2-74: -------------------------------------------------------------------------------- 1 | (define (get-record key) 2 | (define (apply-generic file) 3 | ((get 'search (tag file)) key) 4 | ) 5 | (map apply-generic division-files) 6 | ) 7 | 8 | ; division-file need a "tag" and install the "search" procedure to table 9 | 10 | (define (get-salary record) 11 | ((get 'salary (tag record)) (content record)) 12 | ) 13 | 14 | ; record need a "tag" and install the "salary" procedure 15 | 16 | (define (find-employee-record name division-files) 17 | (define (apply-generic file) 18 | ((get 'search-by-name (tag file)) name) 19 | ) 20 | (map apply-generic division-files) 21 | ) 22 | 23 | ; c 24 | 25 | ; d: 26 | ; new company must tag their files and records while implementing all procedures needed to install -------------------------------------------------------------------------------- /code/Chapter 2/e2-75: -------------------------------------------------------------------------------- 1 | (define (make-from-mag-ang r a) 2 | (define (magnitude z) (car z)) 3 | (define (angle z) (cdr z)) 4 | (define (dispatch op) 5 | (cond ((eq? op 'real-part) (* (magnitude z) (cos (angle z)))) 6 | ((eq? op 'imag-part) (* (magnitude z) (sin (angle z)))) 7 | ((eq? op 'magnitude) r) 8 | ((eq? op 'angle) a) 9 | (else (error "Unknown op: MAKE-FROM-MAG-AND" op)))) 10 | dispatch) 11 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-76: -------------------------------------------------------------------------------- 1 | ; new types may be needed: 2 | ; generic operations with explicit dispatch -- add new clause to explicit dispatch 3 | ; data-directed style -- nothing 4 | ; message-passing-style -- nothing 5 | 6 | ; new operations may be needed: 7 | ; generic operations with explicit dispatch -- change each clause 8 | ; data-directed style -- add new install procedure 9 | ; message-passing-style -- add new dispatch procedure 10 | 11 | ; last two style is better in two situations, I think. -------------------------------------------------------------------------------- /code/Chapter 2/e2-77: -------------------------------------------------------------------------------- 1 | ; this works because first pass dispatch is built, operators for complex have been connected to underlying procedures; 2 | ; 2 times, first is magnitude in complex package, second is magnitude in rectangular package 3 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-78: -------------------------------------------------------------------------------- 1 | (define (type-tag datum) 2 | (cond ((pair? datum) (car datum)) 3 | ((number? datum) 'scheme-number) 4 | (else (error "Bad tagged datum: TYPE-TAG" datum)))) 5 | 6 | (define (attach-tag type-tag contents) 7 | (if (number? contents) 8 | contents 9 | (cons type-tag contents) 10 | ) 11 | ) 12 | 13 | (define (contents datum) 14 | (cond ((pair? datum) (cdr datum)) 15 | ((number? datum) datum) 16 | (else (error "Bad tagged datum: CONTENTS" datum))) 17 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-79: -------------------------------------------------------------------------------- 1 | (define install-equ? 2 | (put 'equ? '(scheme-number scheme-number) (lambda (x y) (= x y))) 3 | (put 'equ? '(rational rational) (lambda (x y) (and (= (numer x) (numer y)) (= (denom x) (denom y))))) 4 | (put 'equ? '(complex complex) (lambda (x y) (and (= (real-part x) (real-part y)) (= (imag-part x) (imag-part y))))) 5 | ) 6 | 7 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-8: -------------------------------------------------------------------------------- 1 | (define (add-interval x y) 2 | (make-interval (+ (lower-bound x) (lower-bound y)) 3 | (+ (upper-bound x) (upper-bound y)))) 4 | 5 | (define (mul-interval x y) 6 | (let ((p1 (* (lower-bound x) (lower-bound y))) 7 | (p2 (* (lower-bound x) (upper-bound y))) 8 | (p3 (* (upper-bound x) (lower-bound y))) 9 | (p4 (* (upper-bound x) (upper-bound y)))) 10 | (make-interval (min p1 p2 p3 p4) 11 | (max p1 p2 p3 p4)))) 12 | 13 | (define (div-interval x y) 14 | (mul-interval 15 | x 16 | (make-interval (/ 1.0 (upper-bound y)) 17 | (/ 1.0 (lower-bound y))))) 18 | 19 | (define (make-interval a b) (cons a b)) 20 | 21 | (define (upper-bound x) 22 | (+ (car x) (* (car x)(cdr x))) 23 | ) 24 | 25 | (define (lower-bound x) 26 | (- (car x) (* (car x)(cdr x))) 27 | ) 28 | 29 | (define (sub-interval x y) 30 | (let ((p1 (- (lower-bound x) (lower-bound y))) 31 | (p2 (- (lower-bound x) (upper-bound y))) 32 | (p3 (- (upper-bound x) (lower-bound y))) 33 | (p4 (- (upper-bound x) (upper-bound y)))) 34 | (make-interval (min p1 p2 p3 p4) 35 | (max p1 p2 p3 p4))) 36 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-80: -------------------------------------------------------------------------------- 1 | (define install-=zero? 2 | (put '=zero? 'scheme-number (lambda (x) (= x 0))) 3 | (put '=zero? 'rational (lambda (x) (= (numer x) 0))) 4 | (put '=zero? 'complex (lambda (x) (and (= (real-part x) 0) (= (imag-part x) 0)))) 5 | ) 6 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-81: -------------------------------------------------------------------------------- 1 | ; a: 2 | ; dead cycle, proc not found --> coerce to same type --> proc not found 3 | 4 | ; b: 5 | ; he is right, two errors are different, but the notice is the same. 6 | 7 | ; c: 8 | 9 | (define (apply-generic op . args) 10 | (let ((type-tags (map type-tag args))) 11 | (let ((proc (get op type-tags))) 12 | (if proc 13 | (apply proc (map contents args)) 14 | (if (= (length args) 2) 15 | (let ((type1 (car type-tags)) (type2 (cadr type-tags)) (a1 (car args)) (a2 (cadr args))) 16 | (if (eqv? type1 type2) 17 | (error "No method for these types" (list op type-tags)) 18 | (let ((t1->t2 (get-coercion type1 type2)) (t2->t1 (get-coercion type2 type1))) 19 | (cond 20 | (t1->t2 (apply-generic op (t1->t2 a1) a2)) 21 | (t2->t1 (apply-generic op a1 (t2->t1 a2))) 22 | (else (error "Can't coerce the first type to the second type" (list op type-tags))) 23 | ) 24 | ) 25 | ) 26 | ) 27 | (error "No method for these types" (list op type-tags)) 28 | ) 29 | ) 30 | ) 31 | ) 32 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-82: -------------------------------------------------------------------------------- 1 | (define (get-n args n) 2 | (if (= n 1) 3 | (car args) 4 | (get-n (cdr args) (- n 1)) 5 | ) 6 | ) 7 | 8 | (define (coerce-to args n) 9 | (let ((target (get-n args n)) (type-target (type-tag (get-n args n)))) 10 | (define (coerce-a-b b) 11 | (let ((type-b (type-tag b))) 12 | (cond 13 | ((eqv? type-target type-b) b) 14 | ((get-coercion typeb type-target) ((get-coercion typeb type-target) (contents b))) 15 | (else false) 16 | ) 17 | ) 18 | ) 19 | (filter (lambda (x) x) (map coerce-a-b args)) 20 | ) 21 | ) 22 | 23 | (define (coerce-and-apply args n op) 24 | (if (> n (length args)) 25 | (error "No method for these args" (list op args)) 26 | (let ((same-type-args (coerce-to args n))) 27 | (if (not (= (length same-type-args) (length args))) 28 | (coerce-and-apply args (+ n 1) op) 29 | (if (get op (map type-tag (coerce-to args n))) 30 | (apply (get op (map type-tag (coerce-to args n))) (map contents args)) 31 | (coerce-and-apply args (+ n 1) op) 32 | ) 33 | ) 34 | ) 35 | ) 36 | ) 37 | 38 | (define (apply-generic op . args) 39 | (let ((type-tags (map type-tag args))) 40 | (let ((proc (get op type-tags))) 41 | (if proc 42 | (apply proc (map contents args)) 43 | (if (> (length args) 1) 44 | (coerce-and-apply args 1 op) 45 | (error "No method for these types" (list op type-tags)) 46 | ) 47 | ) 48 | ) 49 | ) 50 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-83: -------------------------------------------------------------------------------- 1 | (define install-raise 2 | (define (raise a) 3 | (let ((type-a (type-tag a))) 4 | (cond 5 | ((eqv? type-a 'complex) (error "Reach the tower top")) 6 | ((eqv? type-a 'real) ((get-coercion type-a 'complex) (contents a))) 7 | ((eqv? type-a 'rational) ((get-coercion type-a 'real) (contents a))) 8 | ((eqv? type-a 'integer) ((get-coercion type-a 'rational) (contents a))) 9 | (else (error "Can't deal with this type")) 10 | ) 11 | ) 12 | ) 13 | (put 'raise '(integer rational real complex) raise) 14 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-84: -------------------------------------------------------------------------------- 1 | (define install-raise 2 | (define (raise a) 3 | (let ((type-a (type-tag a))) 4 | (cond 5 | ((eqv? type-a 'complex) (error "Reach the tower top")) 6 | ((eqv? type-a 'real) ((get-coercion type-a 'complex) (contents a))) 7 | ((eqv? type-a 'rational) ((get-coercion type-a 'real) (contents a))) 8 | ((eqv? type-a 'integer) ((get-coercion type-a 'rational) (contents a))) 9 | (else (error "Can't deal with this type")) 10 | ) 11 | ) 12 | ) 13 | (put 'raise '(integer rational real complex) raise) 14 | ) 15 | 16 | ; utils 17 | 18 | (define (raise-to a b) 19 | (if (not (higher b a)) ; not higher, means a's level is the same as b's level 20 | a 21 | (raise-to (apply-generic 'raise a) b) 22 | ) 23 | ) 24 | 25 | (define (higher a b) 26 | (define (value-of a) 27 | (cond 28 | ((eqv? (type-tag a) 'integer) 1) 29 | ((eqv? (type-tag a) 'rational) 2) 30 | ((eqv? (type-tag a) 'real) 3) 31 | ((eqv? (type-tag a) 'complex) 4) 32 | ) 33 | ) 34 | (> (value-of a) (value-of b)) 35 | ) 36 | 37 | (define (apply-generic op . args) 38 | (let ((type-tags (map type-tag args))) 39 | (let ((proc (get op type-tags))) 40 | (if proc 41 | (apply proc (map contents args)) 42 | (if (= (length args) 2) 43 | (let ((type1 (car type-tags)) (type2 (cadr type-tags)) (a1 (car args)) (a2 (cadr args))) 44 | (if (eqv? type1 type2) 45 | (error "No method for these types" (list op type-tags)) 46 | (if (tower-higher a1 a2) 47 | (apply-generic op a1 (raise-to a2 a1)) 48 | (apply-generic op (raise-to a1 a2) a2) 49 | ) 50 | ) 51 | ) 52 | (error "No method for these types" (list op type-tags)) 53 | ) 54 | ) 55 | ) 56 | ) 57 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-85: -------------------------------------------------------------------------------- 1 | (define install-project 2 | (define (project a) 3 | (let ((type-a (type-tag a))) 4 | (cond 5 | ((eqv? type-a 'integer) (error "Reach the tower top")) 6 | ((eqv? type-a 'rational) (apply-generic 'numer (contents a))) 7 | ((eqv? type-a 'real) (round (contents a))) 8 | ((eqv? type-a 'complex) (apply-generic 'make-real (apply-generic 'real-part (contents a)))) 9 | (else (error "Can't deal with this type")) 10 | ) 11 | ) 12 | ) 13 | (put 'project '(integer rational real complex) project) ; or install four times use same procedure 14 | ) 15 | 16 | (define install-raise 17 | (define (raise a) 18 | (let ((type-a (type-tag a))) 19 | (cond 20 | ((eqv? type-a 'complex) (error "Reach the tower top")) 21 | ((eqv? type-a 'real) ((get-coercion type-a 'complex) a)) 22 | ((eqv? type-a 'rational) ((get-coercion type-a 'real) a)) 23 | ((eqv? type-a 'integer) ((get-coercion type-a 'rational) a)) 24 | (else (error "Can't deal with this type")) 25 | ) 26 | ) 27 | ) 28 | (put 'raise '(integer rational real complex) raise) 29 | ) 30 | 31 | (define install-drop 32 | (define (drop a) 33 | (if (apply-generic 'equ? a (apply-generic 'raise (apply-generic 'project a))) 34 | (drop (apply-generic 'project a)) 35 | a 36 | ) 37 | ) 38 | (put 'drop '(integer rational real complex) drop) 39 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-86: -------------------------------------------------------------------------------- 1 | ; 1. implement real-part imag-part magnitude and angle that can deal with 3 new types, then install them with new types' list 2 | ; 2. implement sine and cosine that can deal with new types 3 | 4 | ; tired to write code, so I won't implement those two procedures -------------------------------------------------------------------------------- /code/Chapter 2/e2-87: -------------------------------------------------------------------------------- 1 | (define install-=zero? 2 | (define (=zero? a) 3 | (let ((type-a (type-tag a))) 4 | (if ((eqv? type-a 'scheme-number)) 5 | (= (content a) 0) 6 | (=zero? (coeff (content a))) 7 | ) 8 | ) 9 | ) 10 | (put '=zero? '(polynomial scheme-number) =zero?) 11 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-88: -------------------------------------------------------------------------------- 1 | (define install-sub 2 | (define (sub p1 p2) 3 | (apply-generic 'add p1 (apply-generic 'neg p2)) 4 | ) 5 | (put 'sub '(polynomial polynomial) sub) 6 | ) 7 | 8 | (define install-neg 9 | (define (neg p1) 10 | (apply-generic 'mul -1 p1) 11 | ) 12 | (put 'neg 'polynomial neg) 13 | ) 14 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-89: -------------------------------------------------------------------------------- 1 | (define (adjoin-term term term-list) 2 | (cons term term-list) 3 | ) 4 | 5 | (define (first-term term-list) 6 | (car term-list) 7 | ) 8 | (define (rest-terms term-list) 9 | (cdr term-list) 10 | ) 11 | 12 | (define (add-terms L1 L2) 13 | (let ((t1 (first-term L1)) (t2 (first-term L2))) 14 | (adjoin-term (add t1 t2) (add-terms (rest-terms L1) (rest-terms L2))) 15 | ) 16 | ) 17 | 18 | (define (mul-terms L1 L2) 19 | (add-terms (mul-term-by-all-terms (first-term L1) L2) (mul-terms (rest-terms L1) L2)) 20 | ) 21 | (define (mul-term-by-all-terms t1 L) 22 | (let ((t2 (first-term L))) 23 | (adjoin-term 24 | (mul t1 t2) 25 | (mul-term-by-all-terms t1 (rest-terms L)) 26 | ) 27 | ) 28 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-9: -------------------------------------------------------------------------------- 1 | (define (div-interval x y) 2 | (if (= (upper-bound y) (lower-bound y)) 3 | (erro 'zero interval!') 4 | (mul-interval 5 | x 6 | (make-interval (/ 1.0 (upper-bound y)) 7 | (/ 1.0 (lower-bound y)))) 8 | ) 9 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-90: -------------------------------------------------------------------------------- 1 | (define install-dense 2 | (define (adjoin-term term term-list) 3 | (cons term term-list) 4 | ) 5 | (define (first-term term-list) 6 | (car term-list) 7 | ) 8 | (define (rest-terms term-list) 9 | (cdr term-list) 10 | ) 11 | (define (add-terms-1 L1 L2) 12 | (let ((t1 (first-term L1)) (t2 (first-term L2))) 13 | (adjoin-term (add t1 t2) (add-terms-1 (rest-terms L1) (rest-terms L2))) 14 | ) 15 | ) 16 | (define (add-terms L1 L2) 17 | (tag (add-terms-1 (content L1) (content L2))) 18 | ) 19 | (define (mul-terms-1 L1 L2) 20 | (add-terms-1 (mul-term-by-all-terms-1 (first-term L1) L2) (mul-terms (rest-terms L1) L2)) 21 | ) 22 | (define (mul-term-by-all-terms-1 t1 L) 23 | (let ((t2 (first-term L))) 24 | (adjoin-term 25 | (mul t1 t2) 26 | (mul-term-by-all-terms-1 t1 (rest-terms L)) 27 | ) 28 | ) 29 | ) 30 | (define (mul-terms L1 L2) 31 | (tag (mul-terms-1 (content L1) (content L2))) 32 | ) 33 | (define (make-terms terms) 34 | (tag terms) 35 | ) 36 | (define (tag p) (attach-tag 'dense-term p)) 37 | (put 'add-terms 'dense-term add-terms) 38 | (put 'mul-terms 'dense-term mul-terms) 39 | (put 'make 'dense-term make-terms) 40 | ) 41 | 42 | ; dense 43 | 44 | (define install-dense 45 | (define (adjoin-term term term-list) (if (=zero? (coeff term)) 46 | term-list 47 | (cons term term-list))) 48 | (define (the-empty-termlist) '()) 49 | (define (first-term term-list) (car term-list)) (define (rest-terms term-list) (cdr term-list)) (define (empty-termlist? term-list) (null? term-list)) (define (make-term order coeff) (list order coeff)) 50 | (define (add-terms L1 L2) 51 | (tag (add-terms-1 (content L1) (content L2))) 52 | ) 53 | (define (add-terms-1 L1 L2) 54 | (cond ((empty-termlist? L1) L2) 55 | ((empty-termlist? L2) L1) (else 56 | (let ((t1 (first-term L1)) (t2 (first-term L2))) 57 | (cond ((> (order t1) (order t2)) (adjoin-term 58 | t1 (add-terms (rest-terms L1) L2))) 59 | ((< (order t1) (order t2)) 60 | (adjoin-term 61 | t2 (add-terms L1 (rest-terms L2)))) 62 | (else (adjoin-term 63 | (make-term (order t1) 64 | (add (coeff t1) (coeff t2))) 65 | (add-terms (rest-terms L1) 66 | (rest-terms L2))))))))) 67 | 68 | (define (mul-terms-1 L1 L2) (if (empty-termlist? L1) (the-empty-termlist) 69 | (add-terms (mul-term-by-all-terms (first-term L1) L2) 70 | (mul-terms (rest-terms L1) L2)))) 71 | (define (mul-term-by-all-terms-1 t1 L) (if (empty-termlist? L) 72 | (the-empty-termlist) 73 | (let ((t2 (first-term L))) 74 | (adjoin-term 75 | (make-term (+ (order t1) (order t2)) 76 | (mul (coeff t1) (coeff t2))) 77 | (mul-term-by-all-terms t1 (rest-terms L)))))) 78 | (define (mul-terms L1 L2) 79 | (tag (mul-terms-1 (content L1) (content L2))) 80 | ) 81 | (define (make-terms terms) 82 | (tag terms) 83 | ) 84 | (define (tag p) (attach-tag 'sparse-term p)) 85 | (put 'add-terms 'sparse-term add-terms) 86 | (put 'mul-terms 'sparse-term mul-terms) 87 | (put 'make 'sparse-term make-terms) 88 | ) 89 | 90 | ; sparse 91 | 92 | ; explain: 93 | ; above are implements of sparse-term package and dense-term package 94 | ; we should also change poly package, make add and mul operator use apply-generic 95 | ; 96 | ; as for users, they can generate one kind terms list and pass it into make-poly, so other operators don't need to change 97 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-91: -------------------------------------------------------------------------------- 1 | (define (div-terms L1 L2) 2 | (if (empty-termlist? L1) 3 | (list (the-empty-termlist) (the-empty-termlist)) 4 | (let ((t1 (first-term L1)) (t2 (first-term L2))) 5 | (if (> (order t2) (order t1)) 6 | (list (the-empty-termlist) L1) 7 | (let ((new-c (div (coeff t1) (coeff t2))) (new-o (- (order t1) (order t2)))) 8 | (let ((rest-of-result (div-terms (sub-term L1 (mul-term L2 (make-term new-o new-c))) L2))) 9 | (adjoin-term (make-term new-o new-c) rest-of-result) 10 | ) 11 | ) 12 | ) 13 | ) 14 | ) 15 | ) 16 | 17 | (define (div-poly p1 p2) 18 | (if (same-variable? (variable p1) (variable p2)) 19 | (make-poly (variable p1) (div-terms (term-list p1) (term-list p2))) 20 | ) 21 | ) 22 | -------------------------------------------------------------------------------- /code/Chapter 2/e2-93: -------------------------------------------------------------------------------- 1 | ; just make rational add generic 2 | 3 | (define (add-rat x y) 4 | (make-rat (apply-generic 'add (apply-generic 'add (numer x) (denom y)) 5 | (apply-generic 'mul (numer y) (denom x))) 6 | (apply-generic 'mul (denom x) (denom y)))) 7 | 8 | ; ignore other procedures, same as add-rat 9 | 10 | ; here we have two branches, first, two operands are both numbers, so 'add will use + 11 | ; second, two operands are both polys, so 'add will use add-poly -------------------------------------------------------------------------------- /code/Chapter 2/e2-94: -------------------------------------------------------------------------------- 1 | (define install-gcd-poly 2 | (define (div-terms L1 L2) 3 | (if (empty-termlist? L1) 4 | (list (the-empty-termlist) (the-empty-termlist)) 5 | (let ((t1 (first-term L1)) (t2 (first-term L2))) 6 | (if (> (order t2) (order t1)) 7 | (list (the-empty-termlist) L1) 8 | (let ((new-c (div (coeff t1) (coeff t2))) (new-o (- (order t1) (order t2)))) 9 | (let ((rest-of-result (div-terms (sub-term L1 (mul-term L2 (make-term new-o new-c))) L2))) 10 | (adjoin-term (make-term new-o new-c) rest-of-result) 11 | ) 12 | ) 13 | ) 14 | ) 15 | ) 16 | ) 17 | 18 | (define (get-remainder terms) 19 | (if (not (empty-termlist? (car terms))) 20 | (get-remainder (cdr terms)) 21 | (cdr terms) 22 | ) 23 | ) 24 | 25 | (define (remainder-terms a b) 26 | (get-remainder (div-terms a b)) 27 | ) 28 | 29 | (define (gcd-terms a b) (if (empty-termlist? b) 30 | a 31 | (gcd-terms b (remainder-terms a b)))) 32 | (define (gcd-poly p1 p2) 33 | (if (not (same-variable? (variable p1) (variable p2))) 34 | (error "Variables are not the same!") 35 | (make-poly (variable p1) (gcd-terms (term-list p1) (term-list p2))) 36 | ) 37 | ) 38 | (put 'greatest-common-divisor '(polynomial polynomial) gcd-poly) 39 | (define (gcd a b) (if (= b 0) 40 | a 41 | (gcd b (remainder a b)))) 42 | (put 'gcd '(scheme-number scheme-number) gcd) 43 | ) -------------------------------------------------------------------------------- /code/Chapter 2/e2-95: -------------------------------------------------------------------------------- 1 | ; the reason is........computer cannot represent rational number precisely, that's it. -------------------------------------------------------------------------------- /code/Chapter 2/e2-96: -------------------------------------------------------------------------------- 1 | (define (div-terms L1 L2) 2 | (if (empty-termlist? L1) 3 | (list (the-empty-termlist) (the-empty-termlist)) 4 | (let ((t1 (first-term L1)) (t2 (first-term L2))) 5 | (if (> (order t2) (order t1)) 6 | (list (the-empty-termlist) L1) 7 | (let ((new-c (div (coeff t1) (coeff t2))) (new-o (- (order t1) (order t2)))) 8 | (let ((rest-of-result (div-terms (sub-term L1 (mul-term L2 (make-term new-o new-c))) L2))) 9 | (adjoin-term (make-term new-o new-c) rest-of-result) 10 | ) 11 | ) 12 | ) 13 | ) 14 | ) 15 | ) 16 | 17 | (define (get-remainder terms) 18 | (if (not (empty-termlist? (car terms))) 19 | (get-remainder (cdr terms)) 20 | (cdr terms) 21 | ) 22 | ) 23 | 24 | (define (cal-factor a b) 25 | (expt (coeff (car b)) (- (+ 1 (order (car a))) (order (car b)))) 26 | ) 27 | 28 | (define (pseudoremainder-terms a b) 29 | (let ((factor (cal-factor a b))) 30 | (div-term (get-remainder (div-terms (mul-term a factor) (mul-term b factor))) factor) 31 | ) 32 | ) 33 | 34 | (define (gcd-terms a b) (if (empty-termlist? b) 35 | a 36 | (gcd-terms b (pseudoremainder-terms a b)))) 37 | 38 | ; a and b, implement together. mul factor --> get remainder --> div factor -------------------------------------------------------------------------------- /code/Chapter 2/e2-97: -------------------------------------------------------------------------------- 1 | ; ignore dependent procedures, just look previous answer 2 | 3 | (define (gcd-terms a b) (if (empty-termlist? b) 4 | a 5 | (gcd-terms b (pseudoremainder-terms a b)))) 6 | 7 | (define (reduce-terms n d) 8 | (let ((gcd-of-terms (gcd-terms n d))) 9 | (let ((factor (expt (coeff (first-term gcd-terms)) (- (+ 1 (max (order (first-term n)) (order (first-term d)))) (order (first-term gcd-terms)))))) 10 | (list (div-term (div-term (mul-term n factor) gcd-of-terms) factor) (div-term (div-term (mul-term d factor) gcd-of-terms) factor)) 11 | ) 12 | ) 13 | ) 14 | 15 | (define (reduce-poly p1 p2) 16 | (if (not (same-variable? (variable p1) (variable p2))) 17 | (error "Variables are not the same!") 18 | (make-poly (variable p1) (reduce-terms (term-list p1) (term-list p2))) 19 | ) 20 | ) 21 | 22 | ; a 23 | 24 | (define (reduce-integers n d) (let ((g (gcd n d))) 25 | (list (/ n g) (/ d g)))) 26 | 27 | (define install-reduce 28 | 29 | ; paste reduce-integers and reduce-poly here 30 | 31 | (put 'reduce '(scheme-number scheme-number) reduce-integers) 32 | (put 'reduce '(polynomial polynomial) reduce-poly) 33 | ) 34 | 35 | ; b -------------------------------------------------------------------------------- /code/Chapter 2/e2-queen: -------------------------------------------------------------------------------- 1 | (define (enumerate-interval low high) (if (> low high) 2 | '() 3 | (cons low (enumerate-interval (+ low 1) high)))) 4 | 5 | (define (flatmap proc seq) 6 | (accumulate append '() (map proc seq)) 7 | ) 8 | (define (accumulate op initial sequence) 9 | (if (null? sequence) 10 | initial 11 | (op (car sequence) 12 | (accumulate op initial (cdr sequence)) 13 | ) 14 | ) 15 | ) 16 | 17 | ; utils 18 | 19 | (define (queens board-size) 20 | (define (empty-board) 21 | '() 22 | ) 23 | (define (safe? k positions) 24 | (let ((needcheck (car positions))) 25 | (define (check now positions) 26 | (cond 27 | ((= now 0) true) 28 | ((and (not (= (car positions) needcheck)) (not (= (abs (- k now)) (abs (- needcheck (car positions)))))) (check (- now 1) (cdr positions))) 29 | (else false) 30 | ) 31 | ) 32 | (check (- k 1) (cdr positions)) 33 | 34 | ) 35 | ) 36 | (define (adjoin-position new-row k rest-of-queens) 37 | (append (list new-row) rest-of-queens) 38 | ) 39 | (define (queen-cols k) 40 | (if (= k 0) 41 | (list (empty-board)) 42 | (filter 43 | (lambda (positions) (safe? k positions)) 44 | (flatmap 45 | (lambda (rest-of-queens) 46 | (map 47 | (lambda (new-row) 48 | (adjoin-position new-row k rest-of-queens) 49 | ) 50 | (enumerate-interval 1 board-size) 51 | ) 52 | ) 53 | (queen-cols (- k 1)) 54 | ) 55 | ) 56 | ) 57 | ) 58 | (queen-cols board-size) 59 | ) 60 | 61 | (queens 8) -------------------------------------------------------------------------------- /code/Chapter 3/e3-1: -------------------------------------------------------------------------------- 1 | 2 | (define (make-accumulator init) 3 | (lambda (x) (set! init (+ init x)) init) 4 | ) 5 | 6 | (define A (make-accumulator 5)) 7 | 8 | (A 15) 9 | 10 | (A 20) -------------------------------------------------------------------------------- /code/Chapter 3/e3-10: -------------------------------------------------------------------------------- 1 | ; parameter version: balance is stored in make-withdraw's env, which points to global env 2 | ; let version: balance is stored in lambda's env, which points to make-withdraw's env. 3 | ; thus, let version creates one more env -------------------------------------------------------------------------------- /code/Chapter 3/e3-11: -------------------------------------------------------------------------------- 1 | ; (define acc (make-account 50)) 2 | ; make-account create E1 -> global env 3 | ; acc -> global env, body is dispatch procedure, point to E1 4 | ; balance -> E1, value is 50 5 | 6 | ; ((acc 'deposit) 40) 7 | ; deposit -> E1 create E2 -> E1 point to E1 8 | ; amount -> E2, value is 40 9 | ; balance value is 90 10 | 11 | ; ((acc 'withdraw) 60) 12 | ; withdraw -> E1 create E3 -> E1 point to E1 13 | ; amount -> E3, value is 60 14 | ; balance value is 30 15 | 16 | 17 | ; global 18 | ; | 19 | ; | acc -> body 20 | ; | 21 | ; E1 22 | ; | deposit 23 | ; | balance 24 | ; | withdraw 25 | ; | \ 26 | ; | \ 27 | ; | \ 28 | ; E2 E3 29 | ; | | 30 | ; | amount | amount 31 | ; 32 | ; acc's body point to E1 33 | ; deposit's body point to E1 34 | ; withdraw's body point to E1 -------------------------------------------------------------------------------- /code/Chapter 3/e3-12: -------------------------------------------------------------------------------- 1 | ; response 1: (b) 2 | ; response 2: (b c d) -------------------------------------------------------------------------------- /code/Chapter 3/e3-13: -------------------------------------------------------------------------------- 1 | ; this will create a cycle list, a --> b --> c --> a 2 | 3 | ; if we compute (last-pair z), program will execute forever. -------------------------------------------------------------------------------- /code/Chapter 3/e3-14: -------------------------------------------------------------------------------- 1 | ; this will reverse x 2 | 3 | ; v: a 4 | ; w: d --> c --> b --> v 5 | ; value v: (a) 6 | ; value w: (d c b a) 7 | ; 8 | ; because first set-cdr! change the memory of v, while next set-cdr! just change the memory of previous temp. each recursive creates a new temp, and it's changed by next recursive. but v is just changed once. 9 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-15: -------------------------------------------------------------------------------- 1 | ; for z1: the pointer to 'a changes to 'wow 2 | ; for z2: the first pointer to 'a changes to 'wow 3 | 4 | ; have no time to draw a picture, so just use words to describe it. -------------------------------------------------------------------------------- /code/Chapter 3/e3-16: -------------------------------------------------------------------------------- 1 | (define (count-pairs x) 2 | (if (not (pair? x)) 3 | 0 4 | (+ (count-pairs (car x)) 5 | (count-pairs (cdr x)) 6 | 1))) 7 | 8 | ; return 3 9 | ; easy, just normal three pairs 10 | ; return 4 11 | ; a --> b --> c 12 | ; z1 is a pair, right? it's first pointer points to a, it's second pointer points to c 13 | ; return 7 14 | ; same as 4, just let second pointer points to first pointer 15 | ; never return 16 | ; means dead cycle, just let last-pair point to first pair -------------------------------------------------------------------------------- /code/Chapter 3/e3-17: -------------------------------------------------------------------------------- 1 | (define (in-store x store) 2 | (if (null? store) 3 | false 4 | (if (eq? x (car store)) 5 | true 6 | (in-store x (cdr store)) 7 | ) 8 | ) 9 | ) 10 | 11 | (define (check-pair x) 12 | (let ((store '())) 13 | (if (in-store x store) 14 | 0 15 | (begin (append! store (list x)) 1) 16 | ) 17 | ) 18 | ) 19 | 20 | (define (count-pairs x) 21 | (if (not (pair? x)) 22 | 0 23 | (+ (count-pairs (car x)) 24 | (count-pairs (cdr x)) 25 | (check-pair x)))) -------------------------------------------------------------------------------- /code/Chapter 3/e3-18: -------------------------------------------------------------------------------- 1 | 2 | (define (check-cycle L1) 3 | (let ((store '())) 4 | (define (check-store store-1 L) 5 | (if (null? store-1) 6 | (begin (set! store (cons L store)) false) 7 | (if (eq? (car store-1) L) 8 | true 9 | (check-store (cdr store-1) L) 10 | ) 11 | ) 12 | ) 13 | (define (check-cycle-1 L1) 14 | (cond 15 | ((null? L1) false) 16 | ((null? (cdr L1)) false) 17 | ((check-store store L1) true) 18 | (else (check-cycle-1 (cdr L1))) 19 | ) 20 | ) 21 | (check-cycle-1 L1) 22 | ) 23 | ) 24 | 25 | (define x '(a b c)) 26 | 27 | (check-cycle x) 28 | (check-cycle (append! x x)) -------------------------------------------------------------------------------- /code/Chapter 3/e3-19: -------------------------------------------------------------------------------- 1 | ; easy, just store first pointer and find it in cdrs. 2 | 3 | (define (check-cycle L1) 4 | (let ((store '())) 5 | (define (check-store store-1 L) 6 | (if (null? store-1) 7 | (begin (set! store (cons L store)) false) 8 | (if (eq? store-1 L) 9 | true 10 | (check-store (cdr store-1) L) 11 | ) 12 | ) 13 | ) 14 | (set! store L1) 15 | (check-store (cdr L1) store) 16 | ) 17 | ) 18 | 19 | (define x '(a b c)) 20 | 21 | (check-cycle x) 22 | (check-cycle (append! x x)) -------------------------------------------------------------------------------- /code/Chapter 3/e3-2: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define (make-monitored f) 4 | (define calls 0) 5 | (lambda (x) 6 | (if (eqv? x 'how-many-calls?) 7 | calls 8 | (begin 9 | (set! calls (+ calls 1)) 10 | (f x) 11 | ) 12 | ) 13 | ) 14 | ) 15 | 16 | (define s (make-monitored sqrt)) 17 | 18 | (s 100) 19 | 20 | (s 'how-many-calls?) -------------------------------------------------------------------------------- /code/Chapter 3/e3-20: -------------------------------------------------------------------------------- 1 | ; x -> global, x points to E1 -> global which includes 1 2 2 | ; z -> global, z points to E2 -> global which includes x x 3 | ; (set-car! (cdr z) 17), cdr z get global x, set-car! change x's car 1 into 17 4 | ; so car x return 17 -------------------------------------------------------------------------------- /code/Chapter 3/e3-21: -------------------------------------------------------------------------------- 1 | ; recall that there are two pointer in queue, first and last, point to same list, thus there are two a and b after inserting 2 | ; as for deleting, just read the book carefully okay? after deleting, the last pointer isn't influenced, because empty check just use first pointer, and the next time insertion happened the last pointer will point to the right value 3 | 4 | (define (print-queue q) 5 | (display (front-ptr q)) 6 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-22: -------------------------------------------------------------------------------- 1 | 2 | (define (make-queue) 3 | (let ((front-ptr '()) (rear-ptr '())) 4 | (define empty? 5 | (null? front-ptr) 6 | ) 7 | (define (insert x) 8 | (let ((new-pair (cons item '()))) 9 | (cond 10 | ((empty?) (set! front-ptr new-pair) (set! rear-ptr new-pair) front-ptr) 11 | (else (set-cdr! rear-ptr new-pair) (set! rear-ptr new-pair) front-ptr)) 12 | ) 13 | ) 14 | (define delete 15 | (cond 16 | ((empty?) (error "DELETE! called with an empty queue" queue)) 17 | (else (set! front-ptr (cdr front-ptr)) queue) 18 | ) 19 | ) 20 | (define (dispatch m) 21 | (cond 22 | ((eq? m 'insert) insert) 23 | ((eq? m 'delete) (delete)) 24 | ((eq? m 'empty?) (empty?)) 25 | ) 26 | ) 27 | dispatch)) 28 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-23: -------------------------------------------------------------------------------- 1 | ; two direction link list 2 | 3 | (define (front-insert-queue! queue item) 4 | (let ((new-pair (cons item ('() '())))) 5 | (cond 6 | ((empty-queue? queue) (set-front-ptr! queue new-pair) (set-rear-ptr! queue new-pair) queue) 7 | (else (set-cdr! (cdr new-pair) (front-ptr queue)) (set-front-ptr! queue new-pair) queue) 8 | ) 9 | ) 10 | ) 11 | 12 | (define (rear-insert-queue! queue item) 13 | (let ((new-pair (cons item ('() '())))) 14 | (cond 15 | ((empty-queue? queue) (set-front-ptr! queue new-pair) (set-rear-ptr! queue new-pair) queue) 16 | (else (set-car! (cdr new-pair) (rear-ptr queue)) (set-rear-ptr! queue new-pair) queue) 17 | ) 18 | ) 19 | ) 20 | 21 | (define (front-delete-queue! queue item) 22 | (cond 23 | ((empty-queue? queue) (error "DELETE! called with an empty queue" queue)) 24 | (else (set-front-ptr! queue (cdr (cdr (front-ptr queue)))) (set-car! (cdr (front-ptr queue)) '()) queue)) 25 | ) 26 | 27 | (define (rear-delete-queue! queue item) 28 | (cond 29 | ((empty-queue? queue) (error "DELETE! called with an empty queue" queue)) 30 | (else (set-rear-ptr! queue (car (cdr (front-ptr queue)))) (set-cdr! (cdr (rear-ptr queue)) '()) queue)) 31 | ) 32 | 33 | 34 | (define (front-queue queue) 35 | (if (empty-queue? queue) 36 | (error "FRONT called with an empty queue" queue) 37 | (car (front-ptr queue)) 38 | ) 39 | ) 40 | 41 | (define (rear-queue queue) 42 | (if (empty-queue? queue) 43 | (error "FRONT called with an empty queue" queue) 44 | (car (rear-ptr queue)) 45 | ) 46 | ) 47 | 48 | (define (make-queue) (cons '() '())) 49 | (define (front-ptr queue) 50 | (car queue)) 51 | (define (rear-ptr queue) 52 | (cdr queue)) 53 | (define (set-front-ptr! queue item) 54 | (set-car! queue item)) 55 | (define (set-rear-ptr! queue item) 56 | (set-cdr! queue item)) 57 | (define (empty-queue? queue) 58 | (null? (front-ptr queue)) 59 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-24: -------------------------------------------------------------------------------- 1 | (define (assoc key records proc) 2 | (cond ((null? records) false) 3 | ((proc key (caar records)) (car records)) (else (assoc key (cdr records))))) 4 | 5 | 6 | (define (make-table same-key?) 7 | (let ((local-table (list '*table*))) 8 | (define (lookup key-1 key-2) (let ((subtable 9 | (assoc key-1 (cdr local-table) same-key?))) (if subtable 10 | (let ((record 11 | (assoc key-2 (cdr subtable) same-key?))) 12 | (if record (cdr record) false)) false))) 13 | (define (insert! key-1 key-2 value) (let ((subtable 14 | (assoc key-1 (cdr local-table)))) (if subtable 15 | (let ((record 16 | (assoc key-2 (cdr subtable)))) 17 | (if record 18 | (set-cdr! record value) (set-cdr! subtable 19 | (cons (cons key-2 value) 20 | (cdr subtable))))) 21 | (set-cdr! local-table 22 | (cons (list key-1 (cons key-2 value)) 23 | (cdr local-table))))) 24 | 'ok) 25 | (define (dispatch m) 26 | (cond ((eq? m 'lookup-proc) lookup) 27 | ((eq? m 'insert-proc!) insert!) 28 | (else (error "Unknown operation: TABLE" m)))) 29 | dispatch)) -------------------------------------------------------------------------------- /code/Chapter 3/e3-25: -------------------------------------------------------------------------------- 1 | (define (assoc keys records) 2 | (cond 3 | ((null? records) false) 4 | ((equal? (car keys) (caar records)) 5 | (if (not (null? (cdr keys))) 6 | (assoc (cdr keys) (caar records)) 7 | (caar records) 8 | ) 9 | ) 10 | (else (assoc key (cdr records))) 11 | ) 12 | ) 13 | 14 | 15 | 16 | (define (make-table) 17 | (let ((local-table (list '*table*))) 18 | (define (lookup . keys) 19 | (let ((record (assoc keys (cdr local-table)))) 20 | (if record (cdr record) false) 21 | ) 22 | ) 23 | (define (deal-with-insert value keys records) 24 | (if (null? (cdr keys)) 25 | (let ((record (assoc (car keys) (cdr records)))) 26 | (if record 27 | (set-cdr! record value) 28 | (set-cdr! records (cons (cons (car keys) value) (cdr records))) 29 | ) 30 | ) 31 | (let ((subtable (assoc (car keys) (cdr records)))) 32 | (if subtable 33 | (deal-with-insert value (cdr keys) subtable) 34 | (set-cdr! records (cons (cons keys value) (cdr records))) 35 | ) 36 | ) 37 | ) 38 | ) 39 | (define (insert! value . keys) 40 | (deal-with-insert value keys local-table) 41 | 'ok 42 | ) 43 | (define (dispatch m) 44 | (cond 45 | ((eq? m 'lookup-proc) lookup) 46 | ((eq? m 'insert-proc!) insert!) 47 | (else (error "Unknown operation: TABLE" m)) 48 | ) 49 | ) 50 | dispatch 51 | ) 52 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-26: -------------------------------------------------------------------------------- 1 | ; need to store elements into a tree 2 | ; need to modify the insert and lookup procedure 3 | 4 | ; a little tired so I won't write this, just see e2-66 for the core lookup procedure. -------------------------------------------------------------------------------- /code/Chapter 3/e3-27: -------------------------------------------------------------------------------- 1 | ; (memo-fib 3) first calculate fib 2 and store it, then it calculate fib 3 with the stored fib 2, so only need 2 calculations 2 | ; thus it's O(n), because each fib is caculated with two previous stored number 3 | 4 | ; no it won't work, becuase inside fib it will cal fib which does calculate every previous fib. 5 | ; we must change two fib calls inside fib to memo-fib in order to invoke the memo check 6 | 7 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-28: -------------------------------------------------------------------------------- 1 | 2 | (define (or-gate a1 a2 output) 3 | (define (or-action-procedure) 4 | (let ((new-value (logical-or (get-signal a1) (get-signal a2)))) 5 | (after-delay or-gate-delay (lambda () (set-signal! output new-value))))) 6 | (add-action! a1 or-action-procedure) 7 | (add-action! a2 or-action-procedure) 8 | 'ok) -------------------------------------------------------------------------------- /code/Chapter 3/e3-29: -------------------------------------------------------------------------------- 1 | 2 | (define (or-gate a1 a2 output) 3 | (let ((c (make-wire)) (d (make-wire)) (e (make-wire))) 4 | (inverter a1 c) 5 | (inverter a2 d) 6 | (and-gate c d e) 7 | (inverter e output) 8 | ) 9 | 'ok) 10 | 11 | ; or-gate's delay is 2 * inverter's delay + and-gate's delay, conclude from the circuit's graph -------------------------------------------------------------------------------- /code/Chapter 3/e3-3: -------------------------------------------------------------------------------- 1 | (define (make-account balance password) 2 | (define (withdraw amount) 3 | (if (>= balance amount) 4 | (begin (set! balance (- balance amount)) balance) 5 | "Insufficient funds") 6 | ) 7 | (define (deposit amount) 8 | (set! balance (+ balance amount)) 9 | balance) 10 | (define (dispatch p m) 11 | (if (eqv? p password) 12 | (cond 13 | ((eq? m 'withdraw) withdraw) 14 | ((eq? m 'deposit) deposit) 15 | (else (error "Unknown request: MAKE-ACCOUNT" m)) 16 | ) 17 | (error "Incorrect password") 18 | ) 19 | ) 20 | dispatch 21 | ) 22 | 23 | (define acc (make-account 100 'secret-password)) 24 | ((acc 'secret-password 'withdraw) 40) 25 | ((acc 'some-other-password 'deposit) 50) -------------------------------------------------------------------------------- /code/Chapter 3/e3-30: -------------------------------------------------------------------------------- 1 | (define (ripple-carry-adder Ak Bk Sk C) 2 | (define (adder-1 Ak Bk Sk C) 3 | (if (null? Ak) 4 | 'ok 5 | ) 6 | (let ((S (make-wire)) (Cout (make-wire))) 7 | (full-adder (car Ak) (car Bk) (car Ck) C (car Sk) Cout) 8 | (add-1 (cdr Ak) (cdr Bk) (cdr Sk) Cout) 9 | ) 10 | ) 11 | (adder-1 Ak Bk Sk C) 12 | ) 13 | 14 | ; delay is: n * (2 * half-adder + or) = n * (2 * (max (or + and) (2 * and + inverter)) + or) -------------------------------------------------------------------------------- /code/Chapter 3/e3-31: -------------------------------------------------------------------------------- 1 | ; if we don't initialize proc, it will make delay longer than we expect. -------------------------------------------------------------------------------- /code/Chapter 3/e3-32: -------------------------------------------------------------------------------- 1 | ; the order responds to the signal changing order, so it's important 2 | 3 | ; as for the and gate, change from 0, 1 to 1, 0 4 | 5 | ; in FIFO queue: 6 | ; first change 0 to 1, now the input is 1, 1, generate output 1. then change 1 to 0, output is 0 7 | 8 | ; in LIFO queue: 9 | ; first change 1 to 0, now the input is 0, 0, output is still 0. then chagne 0 to 1, output is 0 10 | 11 | ; clearly, different order will generate different output, which will influence many things. -------------------------------------------------------------------------------- /code/Chapter 3/e3-33: -------------------------------------------------------------------------------- 1 | (define (averager a b c) 2 | (multiplier (adder a b) (constant 1/2)) 3 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-34: -------------------------------------------------------------------------------- 1 | ; there are two problems, first will occurs when a losts it's value, second will occurs when a has value 2 | 3 | ; 1. two a are just the same connector, so for example, a has no value and b has value, then both a will get no value, thus we can't calculate a from b 4 | ; so if a loses it's value, it won't get new value from b forever 5 | 6 | ; 2. another problem arises when a has value. now a will equals to b/a, for example a is 2 and b is 8, after calculating a will becomes 8/2 = 4, so we get the wrong answer. -------------------------------------------------------------------------------- /code/Chapter 3/e3-35: -------------------------------------------------------------------------------- 1 | (define (squarer a b) 2 | (define (process-new-value) 3 | (if (has-value? b) 4 | (if (< (get-value b) 0) 5 | (error "square less than 0: SQUARER" (get-value b)) 6 | (set-value! a (sqrt (get-value b) me)) 7 | ) 8 | (if (has-value? a) 9 | (set-value! b (square (get-value a)) me) 10 | ) 11 | ) 12 | ) 13 | (define (process-forget-value) 14 | (forget-value! a me) 15 | (forget-value! b me) 16 | (process-new-value)) 17 | ) 18 | (define (me request) 19 | (cond 20 | ((eq? request 'I-have-a-value) (process-new-value)) 21 | ((eq? request 'I-lost-my-value) (process-forget-value)) 22 | (else (error "Unknown request: MULTIPLIER" 23 | request)))) 24 | (connect a me) 25 | (connect b me) 26 | me) -------------------------------------------------------------------------------- /code/Chapter 3/e3-36: -------------------------------------------------------------------------------- 1 | ; a --> global env, a points to E1 which is created by make-connector 2 | ; when call set-value! of a, proc me create E2 which belongs to and points to E1, then call set-my-value which create E3 which belongs to and points to E1(because set-my-value is defined in E1) 3 | ; then for-each-except is called, it's defined in global env, so it's create E4 which belongs to global but points to E3 4 | 5 | ; that's it -------------------------------------------------------------------------------- /code/Chapter 3/e3-37: -------------------------------------------------------------------------------- 1 | (define (c+ x y) 2 | (let ((z (make-connector))) 3 | (adder x y z) 4 | z)) 5 | 6 | (define (c- x y) 7 | (let ((z (make-connector))) 8 | (subtract x y z) 9 | z)) 10 | 11 | (define (c* x y) 12 | (let ((z (make-connector))) 13 | (mult x y z) 14 | z)) 15 | 16 | (define (c/ x y) 17 | (let ((z (make-connector))) 18 | (divi x y z) 19 | z)) 20 | 21 | (define (cv x) 22 | (let ((z (make-connector))) 23 | (constant x z) 24 | z)) -------------------------------------------------------------------------------- /code/Chapter 3/e3-38: -------------------------------------------------------------------------------- 1 | ; Peter: (set! balance (+ balance 10)) 2 | ; Paul: (set! balance (- balance 20)) 3 | ; Mary: (set! balance (- balance (/ balance 2))) 4 | 5 | ; a: 6 | ; 6 order: 7 | ; Pe Pa M --> 45 8 | ; Pe M Pa --> 35 9 | ; Pa Pe M --> 45 10 | ; Pa M Pe --> 50 11 | ; M Pe Pa --> 40 12 | ; M Pa Pe --> 40 13 | 14 | 15 | ; many possible values......just give one example 16 | 17 | ; Peter read value 100, then Mary read value 100, then Peter cal 110, Mary cal 50, then Peter set to 110, then Mary set to 50. 18 | 19 | ; then Paul - 20, result is 30 -------------------------------------------------------------------------------- /code/Chapter 3/e3-39: -------------------------------------------------------------------------------- 1 | ; except two normal value, there are one special case 2 | ; second proc read x before first set! works (after square operator, because set! is not included in serializer), so result is 11. -------------------------------------------------------------------------------- /code/Chapter 3/e3-4: -------------------------------------------------------------------------------- 1 | (define (make-account balance password) 2 | (define wrong-password-count 0) 3 | (define (withdraw amount) 4 | (if (>= balance amount) 5 | (begin (set! balance (- balance amount)) balance) 6 | "Insufficient funds") 7 | ) 8 | (define (deposit amount) 9 | (set! balance (+ balance amount)) 10 | balance) 11 | (define (dispatch p m) 12 | (if (eqv? p password) 13 | (cond 14 | ((eq? m 'withdraw) withdraw) 15 | ((eq? m 'deposit) deposit) 16 | (else (error "Unknown request: MAKE-ACCOUNT" m)) 17 | ) 18 | (begin (set! wrong-password-count (+ wrong-password-count 1)) (if (> wrong-password-count 7) call-the-cops) (error "Incorrect password")) 19 | ) 20 | ) 21 | dispatch 22 | ) 23 | 24 | (define acc (make-account 100 'secret-password)) 25 | ((acc 'secret-password 'withdraw) 40) 26 | ((acc 'some-other-password 'deposit) 50) 27 | ((acc 'some-other-password 'deposit) 50) 28 | ((acc 'some-other-password 'deposit) 50) 29 | ((acc 'some-other-password 'deposit) 50) 30 | ((acc 'some-other-password 'deposit) 50) 31 | ((acc 'some-other-password 'deposit) 50) 32 | ((acc 'some-other-password 'deposit) 50) 33 | ((acc 'some-other-password 'deposit) 50) -------------------------------------------------------------------------------- /code/Chapter 3/e3-40: -------------------------------------------------------------------------------- 1 | 2 | ; 1000000 3 | ; 1000000 4 | ; 100 5 | ; 1000 6 | ; 10000 7 | ; 100000 8 | ; 10000 9 | 10 | ; after serialize 11 | ; 1000000 -------------------------------------------------------------------------------- /code/Chapter 3/e3-41: -------------------------------------------------------------------------------- 1 | ; don't agree, same. 2 | 3 | ; read temporary balance won't influence anything -------------------------------------------------------------------------------- /code/Chapter 3/e3-42: -------------------------------------------------------------------------------- 1 | ; not safy, because this will change the order of operation 2 | 3 | ; for example, we have an account including $100, we want to +50 -50 +30 -50 -10 4 | 5 | ; as for normal version, result is 70, because each time we call operation, it will be inserted in to serialize queue, FIFO 6 | 7 | ; but for Ben's version, the order of operation is fixed during init. so all operations will be divided into two parts, withdraws and deposits. so the operation queue is -50 -50 -10 +50 +30. we have only 100, so the -10 will raise an error. this won't happen if we use normal version 8 | 9 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-43: -------------------------------------------------------------------------------- 1 | ; no diagrams sorry 2 | 3 | ; 1. 4 | ; exchange 10 and 20 results 20 and 10 5 | ; exchange 10 and 30 results 30 and 10 6 | ; exchange 20 and 30 results 30 and 20 7 | 8 | ; so whatever you exchange, result will still be 10 20 30 9 | 10 | ; 2. 11 | ; for example, exchange 10 and 30 while exchange 20 and 30. possible result is 30 30 0, sum won't change, because operation inside one account is serialized. only possible bug is more than one exchange at the same time, which will exchange "more" 12 | 13 | ; 3. 14 | ; but if individual account is not serialized, this will generate wrong result. for example, exchange 10 30 and 20 30 at the same time, posible result is 30 20 30, because two procs change balance, later one overwrite previous one. -------------------------------------------------------------------------------- /code/Chapter 3/e3-44: -------------------------------------------------------------------------------- 1 | ; Louis is wrong 2 | 3 | ; for exchange, we need to read balance first, so we must lock the account the get the right number. but for transfer, we don't care about balance, so it's ok -------------------------------------------------------------------------------- /code/Chapter 3/e3-45: -------------------------------------------------------------------------------- 1 | ; this will cause dead lock 2 | 3 | ; first, exchange has been serialized, so when we try to deposit or withdraw inside exchange, it won't work, because exchange is executing now. so deposit or withdraw will wait until exchange finished. but exchange is waiting for deopsit or withdraw to finish, thus they will wait forever. -------------------------------------------------------------------------------- /code/Chapter 3/e3-46: -------------------------------------------------------------------------------- 1 | ; easy.... 2 | 3 | ; there are time between test and set operation, so if another test-and-set! proc executes in this time, both will pass the test, so two procs will execute at the same time. -------------------------------------------------------------------------------- /code/Chapter 3/e3-47: -------------------------------------------------------------------------------- 1 | ; just change boolean cell to a number 2 | 3 | (define (make-serializer n) 4 | (let ((mutex (make-mutex n))) 5 | (lambda (p) 6 | (define (serialized-p . args) 7 | (mutex 'acquire) 8 | (let ((val (apply p args))) 9 | (mutex 'release) 10 | val 11 | ) 12 | ) 13 | serialized-p 14 | ) 15 | ) 16 | ) 17 | 18 | (define (make-mutex n) 19 | (define (test-and-set! cell) 20 | (if (< cell n) 21 | (begin (+ cell 1) false) 22 | true 23 | ) 24 | ) 25 | (let ((cell 0)) 26 | (define (the-mutex m) 27 | (cond 28 | ((eq? m 'acquire) (if (test-and-set! cell) (the-mutex 'acquire))) ; retry 29 | ((eq? m 'release) (clear! cell)) 30 | ) 31 | ) 32 | the-mutex 33 | ) 34 | ) 35 | 36 | (define (clear! cell) 37 | (- cell 1) 38 | ) 39 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-48: -------------------------------------------------------------------------------- 1 | ; under this rule, both exchange proc will try a1 first, and only one can lock it, the other must wait, thus avoid deadlock. 2 | 3 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-49: -------------------------------------------------------------------------------- 1 | ; for example: 2 | ; p1 will use a1, and then call p2 which use a2 3 | ; p3 will use a2, and then call p4 which use a1 4 | 5 | ; if concurrent executing, p1 and p3 will lock a1 and a2, then call p2 and p4 which waiting for each other, and create deadlock 6 | 7 | ; the reason is: this method only works in same level procs, can't deal with nested procs. -------------------------------------------------------------------------------- /code/Chapter 3/e3-5: -------------------------------------------------------------------------------- 1 | (define (random-in-range low high) 2 | (let ((range (- high low))) 3 | (+ low (random range)) 4 | ) 5 | ) 6 | 7 | (define (estimate-integral P x1 x2 y1 y2 trials) 8 | (define (monte-carlo trials experiment) 9 | (define (iter trials-remaining trials-passed) 10 | (cond 11 | ((= trials-remaining 0) (/ trials-passed trials)) 12 | ((experiment) (iter (- trials-remaining 1) (+ trials-passed 1))) 13 | (else (iter (- trials-remaining 1) trials-passed)) 14 | ) 15 | ) 16 | (iter trials 0.0) 17 | ) 18 | (define (estimate-integral-1) 19 | (P (random-in-range x1 x2) (random-in-range y1 y2)) 20 | ) 21 | (monte-carlo trials estimate-integral-1) 22 | ) 23 | 24 | (define (pp x y) 25 | (or (< (+ (square (- x 5)) (square (- y 7))) 9) (= (+ (square (- x 5)) (square (- y 7))) 9)) 26 | ) 27 | 28 | (define (estimate-pi P x1 x2 y1 y2 trials) 29 | (/ (* (abs (* (- x2 x1) (- y2 y1))) (estimate-integral P x1 x2 y1 y2 trials)) 9) 30 | ) 31 | 32 | (estimate-pi pp 2.0 8.0 4.0 10.0 100000) -------------------------------------------------------------------------------- /code/Chapter 3/e3-50: -------------------------------------------------------------------------------- 1 | (define (stream-map proc . argstreams) 2 | (if (null? (car argstreams)) 3 | the-empty-stream 4 | (cons (apply proc (map car argstreams)) (apply stream-map (cons proc (map cdr argstreams)))) 5 | ) 6 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-51: -------------------------------------------------------------------------------- 1 | ; 0 1 2 3 4 2 | ; 5 6 3 | 4 | ; first execute show for 5 times 5 | ; second use memoried value, so only execute show for 2 times -------------------------------------------------------------------------------- /code/Chapter 3/e3-52: -------------------------------------------------------------------------------- 1 | ; sum is 105 after (stream-ref y 7) 2 | ; print 14 3 | ; sum is 210 after (display-stream z) 4 | ; print 5 10 15 20 5 | 6 | ; if no memo 7 | 8 | ; sum is 105 after (stream-ref y 7) 9 | ; print 14 10 | ; sum is 315 after (display-stream z) 11 | ; print 5 10 15 20 -------------------------------------------------------------------------------- /code/Chapter 3/e3-53: -------------------------------------------------------------------------------- 1 | ; 2x previous. (1 2 4 8 16 32 ....) -------------------------------------------------------------------------------- /code/Chapter 3/e3-54: -------------------------------------------------------------------------------- 1 | (define (mul-streams s1 s2) (stream-map * s1 s2)) 2 | 3 | (define factorials 4 | (cons-stream 1 (mul-streams (cdr integers) factorials))) -------------------------------------------------------------------------------- /code/Chapter 3/e3-55: -------------------------------------------------------------------------------- 1 | (define (partial-sums s) 2 | (cons-stream (car s) (stream-map (lambda (x, y) (+ x y)) stream (cdr s))) 3 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-56: -------------------------------------------------------------------------------- 1 | (define S (cons-stream 1 (merge (scale-stream S 2) (merge (scale-stream S 3) (scale-stream S 5))))) -------------------------------------------------------------------------------- /code/Chapter 3/e3-57: -------------------------------------------------------------------------------- 1 | ; need n - 1 additions 2 | 3 | ; if not memo, each fib need to calculate all previous fibs, so it's O(n^2) -------------------------------------------------------------------------------- /code/Chapter 3/e3-58: -------------------------------------------------------------------------------- 1 | ; (1 4 2 8 5 7 1 4 2 8 5 7 ......) 2 | 3 | ; (3 7 5 0 0 0 0 ......) -------------------------------------------------------------------------------- /code/Chapter 3/e3-59: -------------------------------------------------------------------------------- 1 | ; a 2 | 3 | (define (integrate-series s) 4 | (cons-stream (stream-map (lambda (x, y) (* (/ 1 x) y)) integers s)) 5 | ) 6 | 7 | ; b 8 | 9 | (define cosine-series (cons-stream 1 (stream-map (lambda (x) (- 0 x)) sine-series))) 10 | 11 | (define sine-series (cons-stream 0 cosine-series)) -------------------------------------------------------------------------------- /code/Chapter 3/e3-6: -------------------------------------------------------------------------------- 1 | (define rand 2 | (let ((x random-init)) 3 | (lambda (y . arg) 4 | (cond 5 | ((eqv? y 'generate) (set! x (rand-update x)) x) 6 | ((eqv? y 'reset) (set! x (car arg)) x) 7 | ) 8 | ) 9 | ) 10 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-60: -------------------------------------------------------------------------------- 1 | ; can't understand question, so just write something I think maybe is the answer. sorry 2 | 3 | (define (mul-series s1 s2) 4 | (cons-stream (+ (car s1) (car s2)) (add-streams (cdr s1) (cdr s2)))) -------------------------------------------------------------------------------- /code/Chapter 3/e3-61: -------------------------------------------------------------------------------- 1 | (define (invert-unit-series s) 2 | (cons-stream 1 (stream-map (lambda (x y) (- 1 (mul-series (cdr s) (invert-unit-series s)))))) 3 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-63: -------------------------------------------------------------------------------- 1 | ; second version is recursive, so each time we extract value from stream, it will generate a new proc, thus can't trigger the memory 2 | ; if there is no memo part, two versions are the same -------------------------------------------------------------------------------- /code/Chapter 3/e3-64: -------------------------------------------------------------------------------- 1 | (define (stream-limit s tolerance) 2 | (define (inner prev s) 3 | (if (< (abs (- (car-stream s) prev)) tolerance) 4 | (car-stream s) 5 | (inner (car-stream s) (cdr-stream s)) 6 | ) 7 | ) 8 | (inner (car-stream s) (cdr-stream s)) 9 | ) 10 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-65: -------------------------------------------------------------------------------- 1 | (define (ln-2 n) 2 | (cons-stream 1 (stream-map - (ln-2 (/ 1 n))))) 3 | 4 | ; just copy other acceleration procs 5 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-66: -------------------------------------------------------------------------------- 1 | ; (1 100): 1+2*(1+2+3+...+99) 2 | 3 | ; (99 100): 1+2*(1+2+3+...+99) + 98*2 4 | 5 | ; (100 100): 1+2*(1+2+3+...+99) + 99*2 -------------------------------------------------------------------------------- /code/Chapter 3/e3-67: -------------------------------------------------------------------------------- 1 | (define (pairs s t) 2 | (cons-stream 3 | (list (stream-car s) (stream-car t)) 4 | (interleave 5 | (stream-map (lambda (x) (list (stream-car s) x)) (stream-cdr t)) 6 | (pairs (stream-cdr s) (stream-cdr t)) 7 | ) 8 | ) 9 | ) 10 | 11 | (define (swap s) 12 | (cons-stream 13 | (list (cadr (stream-car s)) (car (stream-car s))) 14 | (swap (stream-cdr s)) 15 | ) 16 | ) 17 | 18 | (define (answer s t) 19 | (interleave 20 | (pairs s t) 21 | (swap (pairs s t)) 22 | ) 23 | ) 24 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-68: -------------------------------------------------------------------------------- 1 | ; this will generate (0 0) (1 1) (0 1) (2 2) (0 2) (3 3) (0 0 ) (4 4)..... 2 | 3 | ; so it doesn't work 4 | 5 | ; the reason is, it's interleave two infinite queue, first is the (0 0) (0 1) (0 2)..., second is the (1 1) (2 2) (3 3).... thus other pairs won't be able to accessed 6 | 7 | ; the correct version works because it change the vertical queue to a finite queue, it's height equals to T, so it can access all pairs. you can't interleave two infinite queue -------------------------------------------------------------------------------- /code/Chapter 3/e3-69: -------------------------------------------------------------------------------- 1 | (define (triple s1 s2 s3) 2 | (let ((pair (pairs s1 s2))) 3 | (stream-map (lambda (x) (append x (sqrt (+ (square (car x)) (square (cadr x)))))) pairs) 4 | ) 5 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-7: -------------------------------------------------------------------------------- 1 | (define (make-account balance password) 2 | (define (withdraw amount) 3 | (if (>= balance amount) 4 | (begin (set! balance (- balance amount)) balance) 5 | "Insufficient funds") 6 | ) 7 | (define (deposit amount) 8 | (set! balance (+ balance amount)) 9 | balance) 10 | (define (lock-with password) 11 | (dispatch password) 12 | ) 13 | (define (dispatch password) 14 | (lambda (p m) 15 | (if (eqv? p password) 16 | (cond 17 | ((eq? m 'withdraw) withdraw) 18 | ((eq? m 'deposit) deposit) 19 | ((eq? m 'share) lock-with) 20 | (else (error "Unknown request: MAKE-ACCOUNT" m)) 21 | ) 22 | (error "Incorrect password") 23 | ) 24 | ) 25 | ) 26 | (lock-with password) 27 | ) 28 | 29 | (define (make-joint acc p1 p2) 30 | ((acc p1 'share) p2) 31 | ) 32 | 33 | (define acc (make-account 100 'secret-password)) 34 | ((acc 'secret-password 'withdraw) 40) 35 | ((acc 'some-other-password 'deposit) 50) 36 | 37 | (define paul-acc 38 | (make-joint acc 'secret-password 'rosebud)) 39 | 40 | ((paul-acc 'rosebud 'withdraw) 10) -------------------------------------------------------------------------------- /code/Chapter 3/e3-70: -------------------------------------------------------------------------------- 1 | (define (merge s1 s2 comp) 2 | (cond 3 | ((stream-null? s1) s2) 4 | ((stream-null? s2) s1) 5 | (else 6 | (let ((s1car (stream-car s1)) (s2car (stream-car s2))) 7 | (cond 8 | ((= (comp s1car s2car) -1) (cons-stream s1car (merge (stream-cdr s1) s2 comp))) 9 | ((= (comp s1car s2car) 1) (cons-stream s2car (merge s1 (stream-cdr s2) comp))) 10 | (else (cons-stream s1car (merge (stream-cdr s1) (stream-cdr s2) comp))) 11 | ) 12 | ) 13 | ) 14 | ) 15 | ) 16 | 17 | 18 | (define (weighted-pairs s t comp) 19 | (cons-stream 20 | (list (stream-car s) (stream-car t)) 21 | (merge 22 | (stream-map (lambda (x) (list (stream-car s) x)) (stream-cdr t)) 23 | (weighted-pairs (stream-cdr s) (stream-cdr t)) 24 | comp 25 | ) 26 | ) 27 | ) 28 | 29 | (define (first-comp x y) 30 | (let ((sum1 (+ (car x) (cadr x))) (sum2 (+ (car y) (cadr y)))) 31 | (cond 32 | ((< sum1 sum2) -1) 33 | ((> sum1 sum2) 1) 34 | (else 0) 35 | ) 36 | ) 37 | ) 38 | 39 | 40 | (define (second-comp x y) 41 | (let ((sum1 (+ (* 2 (car x)) (* 3 (cadr x)) (* 5 (car x) (cadr x)))) (sum2 (+ (* 2 (car y)) (* 3 (cadr y)) (* 5 (car y) (cadr y))))) 42 | (cond 43 | ((< sum1 sum2) -1) 44 | ((> sum1 sum2) 1) 45 | (else 0) 46 | ) 47 | ) 48 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-71: -------------------------------------------------------------------------------- 1 | (define (merge s1 s2 comp) 2 | (cond 3 | ((stream-null? s1) s2) 4 | ((stream-null? s2) s1) 5 | (else 6 | (let ((s1car (stream-car s1)) (s2car (stream-car s2))) 7 | (cond 8 | ((= (comp s1car s2car) -1) (cons-stream s1car (merge (stream-cdr s1) s2 comp))) 9 | ((= (comp s1car s2car) 1) (cons-stream s2car (merge s1 (stream-cdr s2) comp))) 10 | (else (cons-stream s1car (merge (stream-cdr s1) (stream-cdr s2) comp))) 11 | ) 12 | ) 13 | ) 14 | ) 15 | ) 16 | 17 | 18 | (define (weighted-pairs s t comp) 19 | (cons-stream 20 | (list (stream-car s) (stream-car t)) 21 | (merge 22 | (stream-map (lambda (x) (list (stream-car s) x)) (stream-cdr t)) 23 | (weighted-pairs (stream-cdr s) (stream-cdr t)) 24 | comp 25 | ) 26 | ) 27 | ) 28 | 29 | (define (first-comp x y) 30 | (let ((sum1 (+ (cube (car x)) (cube (cadr x)))) (sum2 (+ (cube (car y)) (cube (cadr y))))) 31 | (cond 32 | ((< sum1 sum2) -1) 33 | ((> sum1 sum2) 1) 34 | (else 0) 35 | ) 36 | ) 37 | ) 38 | 39 | (define (find-number s) 40 | (let ((s2 (cdr s))) 41 | (stream-map (lambda (x y) 42 | (if (and (= (car x) (car y)) (= (cadr x) (cadr y)))) 43 | (display x) 44 | ) s s2) 45 | ) 46 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-72: -------------------------------------------------------------------------------- 1 | (define (merge s1 s2 comp) 2 | (cond 3 | ((stream-null? s1) s2) 4 | ((stream-null? s2) s1) 5 | (else 6 | (let ((s1car (stream-car s1)) (s2car (stream-car s2))) 7 | (cond 8 | ((= (comp s1car s2car) -1) (cons-stream s1car (merge (stream-cdr s1) s2 comp))) 9 | ((= (comp s1car s2car) 1) (cons-stream s2car (merge s1 (stream-cdr s2) comp))) 10 | (else (cons-stream s1car (merge (stream-cdr s1) (stream-cdr s2) comp))) 11 | ) 12 | ) 13 | ) 14 | ) 15 | ) 16 | 17 | 18 | (define (weighted-pairs s t comp) 19 | (cons-stream 20 | (list (stream-car s) (stream-car t)) 21 | (merge 22 | (stream-map (lambda (x) (list (stream-car s) x)) (stream-cdr t)) 23 | (weighted-pairs (stream-cdr s) (stream-cdr t)) 24 | comp 25 | ) 26 | ) 27 | ) 28 | 29 | (define (first-comp x y) 30 | (let ((sum1 (+ (square (car x)) (square (cadr x)))) (square (+ (cube (car y)) (square (cadr y))))) 31 | (cond 32 | ((< sum1 sum2) -1) 33 | ((> sum1 sum2) 1) 34 | (else 0) 35 | ) 36 | ) 37 | ) 38 | 39 | (define (find-number s) 40 | (let ((s2 (cdr s)) (s3 (cddr s))) 41 | (stream-map (lambda (x y z) 42 | (if (and (= (car x) (car y) (car z)) (= (cadr x) (cadr y) (cadr z)))) 43 | (display x) 44 | ) s s2 s3) 45 | ) 46 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-73: -------------------------------------------------------------------------------- 1 | (define (RC R C dt) 2 | (define (inner i v0) 3 | (stream-map 4 | (lambda (x) 5 | (+ x v0) 6 | ) 7 | (add-streams 8 | (scale-stream (integral i v0 dt) (/ 1 C)) 9 | (scale-stream i R) 10 | ) 11 | ) 12 | ) 13 | (lambda (i v0) 14 | (inner i v0) 15 | ) 16 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-74: -------------------------------------------------------------------------------- 1 | (define zero-crossings 2 | (stream-map sign-change-detector sense-data (cons-stream 0 sense-data)) 3 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-75: -------------------------------------------------------------------------------- 1 | (define (make-zero-crossings input-stream last-value last-avpt) 2 | (let ((avpt (/ (+ (stream-car input-stream) 3 | last-value) 4 | 2))) 5 | (cons-stream 6 | (sign-change-detector avpt last-avpt) 7 | (make-zero-crossings 8 | (stream-cdr input-stream) (stream-car input-stream) avpt)))) -------------------------------------------------------------------------------- /code/Chapter 3/e3-76: -------------------------------------------------------------------------------- 1 | 2 | (define zero-crossings 3 | (let ((sense-data (smooth sense-data))) 4 | (stream-map sign-change-detector sense-data (cons-stream 0 sense-data)) 5 | ) 6 | ) 7 | 8 | (define (smooth s) 9 | (let ((s2 (stream-cdr s))) 10 | (map (lambda (x y) (/ (+ x y) 2)) s s2) 11 | ) 12 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-77: -------------------------------------------------------------------------------- 1 | (define (integral delayed-integrand initial-value dt) 2 | (define int 3 | (cons-stream 4 | initial-value 5 | (let ((integrand (force delayed-integrand))) 6 | (int (stream-cdr integrand) (+ (* dt (stream-car integrand)) initial-value) dt) 7 | ) 8 | ) 9 | int 10 | ) 11 | ) 12 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-78: -------------------------------------------------------------------------------- 1 | (define (solve-2nd a b dt y0 dy0) 2 | (define y (integral (delay dy) y0 dt)) 3 | (define dy (integral (delay ddy) dy0 dt)) 4 | (define ddy (stream-add (scale-stream a dy) (scale-stream b y))) 5 | y 6 | ) 7 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-79: -------------------------------------------------------------------------------- 1 | (define (solve-2nd f dt y0 dy0) 2 | (define y (integral (delay dy) y0 dt)) 3 | (define dy (integral (delay ddy) dy0 dt)) 4 | (define ddy (stream-map f y dy)) 5 | y 6 | ) 7 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-8: -------------------------------------------------------------------------------- 1 | (define f 2 | (let ((a '())) 3 | (lambda (init) 4 | (if (null? a) 5 | (begin (set! a init) a) 6 | 0 7 | ) 8 | ) 9 | ) 10 | ) 11 | 12 | (+ (f 0) (f 1)) -------------------------------------------------------------------------------- /code/Chapter 3/e3-80: -------------------------------------------------------------------------------- 1 | (define (RLC R L C dt ) 2 | (define (inner vc0 il0) 3 | (define vc (integral (delay dvc) vc0 dt)) 4 | (define dvc (scale-stream il (/ 1 C))) 5 | (define il (integral (delay dil) il0 dt)) 6 | (define dil (stream-add (scale-stream vc (/ 1 L)) (scale-stream il (- 0 (/ R L))))) 7 | (cons-stream vc il) 8 | ) 9 | inner 10 | ) -------------------------------------------------------------------------------- /code/Chapter 3/e3-81: -------------------------------------------------------------------------------- 1 | (define (random-numbers-of request-stream) 2 | (define random-numbers (cons-stream 3 | random-init 4 | (stream-map rand-update random-numbers))) 5 | 6 | (define response-of 7 | (cons-stream 8 | (cons (cdr request-stream) random-numbers) ; as for first request, generate and reset is the same 9 | (stream-map 10 | (lambda (x) 11 | (cond 12 | ((eq? (car (car x)) 'generate) (cons (cdr (car x)) (cdr (cdr x)))) 13 | ((eq? (car (car x)) 'reset) (cons (cdr (car x)) random-numbers)) 14 | ) 15 | ) 16 | response-of 17 | ) 18 | ) 19 | ) 20 | (stream-map (lambda (x) (car (cdr x))) response-of) ; x is (request-stream random-number), car the first number of random-number is the answer we want 21 | ) 22 | 23 | 24 | ; explain: 25 | ; suppose the random-number is 3 5 6 1 2... 26 | ; suppose the request is g r g g and r g r g 27 | ; for g r g g: 28 | ; it's 3 3 5 6 29 | ; for r g r g: 30 | ; it's 3 5 3 5 31 | ; 32 | ; use this example, you can understand why first request is the same. -------------------------------------------------------------------------------- /code/Chapter 3/e3-82: -------------------------------------------------------------------------------- 1 | (define (pp x y) 2 | (or (< (+ (square (- x 5)) (square (- y 7))) 9) (= (+ (square (- x 5)) (square (- y 7))) 9)) 3 | ) 4 | 5 | (define (estimate-pi P x1 x2 y1 y2) 6 | (define (random-in-range low high) 7 | (let ((range (- high low))) 8 | (+ low (random range)) 9 | ) 10 | ) 11 | (define random-points 12 | (cons-stream 13 | (cons (random-in-range x1 x2) (random-in-range y1 y2)) 14 | random-points 15 | ) 16 | ) 17 | (define cesaro-stream 18 | (lambda (point) (P (car point) (cdr point)) random-points)) 19 | (define (monte-carlo experiment-stream passed failed) 20 | (define (next passed failed) 21 | (cons-stream 22 | (/ passed (+ passed failed)) 23 | (monte-carlo 24 | (stream-cdr experiment-stream) passed failed))) (if (stream-car experiment-stream) 25 | (next (+ passed 1) failed) 26 | (next passed (+ failed 1)))) 27 | (stream-map (lambda (p) (/ (* (abs (* (- x2 x1) (- y2 y1))) p) 9)) (monte-carlo cesaro-stream 0 0)) 28 | ) 29 | -------------------------------------------------------------------------------- /code/Chapter 3/e3-9: -------------------------------------------------------------------------------- 1 | ; 1. recursive version 2 | ; each call will create a new frame, which points to previous frame (because ) 3 | 4 | ; 2. iterative version 5 | ; same as 1. without tail recursion optimize -------------------------------------------------------------------------------- /code/Chapter 4/e4-1: -------------------------------------------------------------------------------- 1 | (define (list-of-values exps env) 2 | (if (no-operands? exps) 3 | '() 4 | (let ((left (eval (first-operand exps) env))) 5 | (cons left (list-of-values (rest-operands exps) env)) 6 | ) 7 | ) 8 | ) 9 | 10 | ; left to right 11 | 12 | (define (list-of-values exps env) 13 | (if (no-operands? exps) 14 | '() 15 | (let ((right (list-of-values (rest-operands exps) env))) 16 | (cons (eval (first-operand exps) env)) 17 | ) 18 | ) 19 | ) 20 | -------------------------------------------------------------------------------- /code/Chapter 4/e4-10: -------------------------------------------------------------------------------- 1 | ; just show one example, change if to whether 2 | 3 | (define (if? exp) (tagged-list? exp 'whether)) 4 | (define (if-predicate exp) (cadr exp)) 5 | (define (if-consequent exp) (caddr exp)) 6 | (define (if-alternative exp) 7 | (if (not (null? (cdddr exp))) (cadddr exp) 8 | 'false)) 9 | 10 | ; don't need to modify eval proc, just modify the middle layer -------------------------------------------------------------------------------- /code/Chapter 4/e4-11: -------------------------------------------------------------------------------- 1 | (define (make-frame variables values) (map (lambda (x y) (cons x y)) variables values)) 2 | 3 | (define (add-binding-to-frame! var val frame) 4 | (set-car! frame (cons (cons var val) frame))) 5 | 6 | (define (lookup-variable-value var env) 7 | (define (env-loop env) 8 | (define (scan frame) 9 | (cond 10 | ((null? frame) (env-loop (enclosing-environment env))) 11 | ((eq? var (caar frame)) (cdar frame)) 12 | (else (scan (cdr frame))))) 13 | (if (eq? env the-empty-environment) 14 | (error "Unbound variable" var) 15 | (let ((frame (first-frame env))) 16 | (scan frame)))) 17 | (env-loop env)) 18 | 19 | ; just show lookup, define and set is similar 20 | -------------------------------------------------------------------------------- /code/Chapter 4/e4-12: -------------------------------------------------------------------------------- 1 | 2 | (define (find-and-exec var val env p1 p2) 3 | (let ((frame (first-frame env))) 4 | (define (scan vars vals) 5 | (cond ((null? vars) 6 | (p1 frame)) ((eq? var (car vars)) (p2 vals val)) (else (scan (cdr vars) (cdr vals))))) 7 | (scan (frame-variables frame) (frame-values frame))) 8 | ) 9 | 10 | (define (define-variable! var val env) (find-and-exec var val env (lambda (f) (add-binding-to-frame! var val f)) (lambda (x y) (set-car! x y)))) 11 | 12 | 13 | (define (set-variable-value! var val env) 14 | (define (env-loop env) 15 | (if (eq? env the-empty-environment) 16 | (error "Unbound variable: SET!" var) 17 | (find-and-exec var val env (lambda (x) (env-loop (enclosing-environment env))) (lambda (x y) (set-car! x y))) 18 | )) 19 | (env-loop env)) 20 | 21 | 22 | (define (lookup-variable-value var env) 23 | (define (env-loop env) 24 | (if (eq? env the-empty-environment) 25 | (error "Unbound variable" var) 26 | (find-and-exec var val env (lambda (x) (env-loop (enclosing-environment env))) (lambda (x y) (car x))) 27 | )) 28 | (env-loop env)) 29 | -------------------------------------------------------------------------------- /code/Chapter 4/e4-13: -------------------------------------------------------------------------------- 1 | ; just unbound first frame's variable, proc shouldn't control outer env's content 2 | 3 | (define (make-unbound! var env) 4 | (find-and-exec var val env (lambda (f) (display "no such var" var)) (lambda (x y) (cdr x))) 5 | ) 6 | 7 | ; find-and-exec is defined in e4-12 -------------------------------------------------------------------------------- /code/Chapter 4/e4-14: -------------------------------------------------------------------------------- 1 | ; because we haven't add eval-map to implements, so it can't connect to the primitive map proc -------------------------------------------------------------------------------- /code/Chapter 4/e4-16: -------------------------------------------------------------------------------- 1 | ; a 2 | 3 | (define (find-and-exec var val env p1 p2) 4 | (let ((frame (first-frame env))) 5 | (define (scan vars vals) 6 | (cond ((null? vars) 7 | (p1 frame)) ((eq? var (car vars)) (if (eq? (car vals) '*unassigned*) (error "try to access unassigned variable" var)) (p2 vals val)) (else (scan (cdr vars) (cdr vals))))) 8 | (scan (frame-variables frame) (frame-values frame))) 9 | ) 10 | 11 | ; b 12 | 13 | (define (filter-defines body) 14 | (if (not (null? body)) 15 | (if (eq? (caar body) 'define) 16 | (cons (caar body) (filter-defines (cdr body))) 17 | (filter-defines (cdr body)) 18 | ) 19 | '() 20 | ) 21 | ) 22 | 23 | (define (filter-out-defines body) 24 | (if (null? body) 25 | '() 26 | (if (eq? (caar body) 'define) 27 | (filter-defines (cdr body)) 28 | (cons (caar body) (filter-defines (cdr body))) 29 | ) 30 | ) 31 | ) 32 | 33 | (define (make-let defines) 34 | (list let (map (lambda (define) (cons (cadr define) '*unassigned*)) defines)) 35 | ) 36 | 37 | (define (make-set defines) 38 | (list set! (map (lambda (define) (cons (cadr define) (cddr define))) defines)) 39 | ) 40 | 41 | (define (scan-out-defines body) 42 | (let ((defines (filter-defines body)) (other-exps (filter-out-defines body))) 43 | (list (make-let defines) (make-set defines) other-exps) 44 | ) 45 | ) 46 | 47 | ; c 48 | 49 | ; in make-procedure, just do it when necessary, more efficient -------------------------------------------------------------------------------- /code/Chapter 4/e4-17: -------------------------------------------------------------------------------- 1 | ; as usual, ignore diagram. 2 | 3 | ; the extra frame is created for that let exp 4 | ; because lookup proc will check all higher frames, so one extra frame won't influence the program 5 | ; we can change let to set!, thus don't need to create an extra frame -------------------------------------------------------------------------------- /code/Chapter 4/e4-18: -------------------------------------------------------------------------------- 1 | ; this won't work, because when eval e1 and e2, the corresponding y and dy are both unassigned. 2 | ; text's method will work, because dy is delayed, when it's executed, set! has finished. -------------------------------------------------------------------------------- /code/Chapter 4/e4-19: -------------------------------------------------------------------------------- 1 | ; I support Eva, I think internal defines should be executed before other exps. 2 | 3 | ; for implement, compiler need to analyse and find out the dependence between defines, then modify the order of defines. -------------------------------------------------------------------------------- /code/Chapter 4/e4-2: -------------------------------------------------------------------------------- 1 | ; a: 2 | ; procedures will be executed before assignment, no value to use 3 | 4 | ; b 5 | 6 | (define (application? exp) (eq? (car exp) 'call)) 7 | (define (operator exp) (cadr exp)) 8 | (define (operands exp) (cddr exp)) 9 | (define (no-operands? ops) (null? ops)) 10 | (define (first-operand ops) (car ops)) 11 | (define (rest-operands ops) (cdr ops)) -------------------------------------------------------------------------------- /code/Chapter 4/e4-20: -------------------------------------------------------------------------------- 1 | ; a: 2 | ; just use the same proc of e4-16 3 | 4 | ; b: 5 | ; ignore diagram -------------------------------------------------------------------------------- /code/Chapter 4/e4-21: -------------------------------------------------------------------------------- 1 | ; a: 2 | ; yes, that's right. the trick is, you must pass proc to itself in order to reference it inside itself 3 | 4 | 5 | (define (f x) 6 | ( 7 | (lambda (even? odd?) (even? even? odd? x)) 8 | (lambda (ev? od? n) (if (= n 0) true (od? ev? od? (- n 1)))) 9 | (lambda (ev? od? n) (if (= n 0) false (ev? ev? od? (- n 1)))))) -------------------------------------------------------------------------------- /code/Chapter 4/e4-22: -------------------------------------------------------------------------------- 1 | (define (let-vars clause) 2 | (map (lambda (x) (car x)) (cadr clause)) 3 | ) 4 | 5 | (define (let-exps clause) 6 | (map (lambda (x) (cdr x)) (cadr clause)) 7 | ) 8 | 9 | (define (let-body clause) 10 | (cddr clause) 11 | ) 12 | 13 | (define (analyze-let exp) 14 | ((analyze-lambda (let-vars exp) (let-body exp)) (let-exps exp)) 15 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-23: -------------------------------------------------------------------------------- 1 | ; compare two version: 2 | ; proc in text change the sequence into a lambda proc which can be executed directly 3 | ; proc in exercise, just change each exp inside the sequence into lambda procs, but when execute this sequence, we still need to do the car and cdr operations, which makes this version inefficient. 4 | ; that's the reason why Eva said second version doesn't analyze the sequence itself -------------------------------------------------------------------------------- /code/Chapter 4/e4-25: -------------------------------------------------------------------------------- 1 | ; this will generate inifinite recursive 2 | ; because the logic will first eval factorial n - 1 then check whether n = 1, thus will call factorial with n - 1 without terminal 3 | 4 | ; in normal-order it's okay -------------------------------------------------------------------------------- /code/Chapter 4/e4-26: -------------------------------------------------------------------------------- 1 | (define (unless condition usual-value exceptional-value) 2 | (cond (condition usual-value) (else exceptional-value)) 3 | ) 4 | 5 | ; to be honest, can't understand the exercise, so just write the derived expression -------------------------------------------------------------------------------- /code/Chapter 4/e4-27: -------------------------------------------------------------------------------- 1 | ; 0 2 | ; 3 | ; 10 4 | ; 5 | ; 2 6 | 7 | ; because of lazy evaluation, just after triggering w, count is changed -------------------------------------------------------------------------------- /code/Chapter 4/e4-28: -------------------------------------------------------------------------------- 1 | ((if (eq? 1 0) + -) 1 2) 2 | 3 | ; if we don't force operator, this will be treated as compound operator, but in fact it's primitive operator -------------------------------------------------------------------------------- /code/Chapter 4/e4-29: -------------------------------------------------------------------------------- 1 | ; recall the fib! without memorize it's O(n), with memorize it's O(logn) 2 | 3 | ; with memorize 4 | 5 | ; 100 6 | ; 7 | ; 1 8 | 9 | ; without memorize 10 | 11 | ; 100 12 | ; 13 | ; 2 -------------------------------------------------------------------------------- /code/Chapter 4/e4-3: -------------------------------------------------------------------------------- 1 | (define (eval-install) 2 | (define (self-eval exp) 3 | exp 4 | ) 5 | (define (var1 exp env) 6 | (lookup-variable-value exp env) 7 | ) 8 | (define (quote1 exp) 9 | (text-of-quotation exp) 10 | ) 11 | (define (set1 exp env) 12 | (eval-assignment exp env) 13 | ) 14 | (define (define1 exp env) 15 | (eval-definition exp env) 16 | ) 17 | (define (if1 exp env) 18 | (eval-if exp env) 19 | ) 20 | (define (lambda1 exp env) 21 | (make-procedure (lambda-parameters exp) 22 | (lambda-body exp) 23 | env) 24 | ) 25 | (define (begin1 exp env) 26 | (eval-sequence (begin-actions exp) env) 27 | ) 28 | (define (cond1 exp env) 29 | (eval (cond->if exp) env) 30 | ) 31 | (define (apply1 exp env) 32 | (apply (eval (operator exp) env) 33 | (list-of-values (operands exp) env)) 34 | ) 35 | (put 'eval 'self-eval self-eval) 36 | (put 'eval 'var var1) 37 | (put 'eval 'quote quote1) 38 | (put 'eval 'set set1) 39 | (put 'eval 'define define1) 40 | (put 'eval 'if if1) 41 | (put 'eval 'lambda lambda1) 42 | (put 'eval 'begin begin1) 43 | (put 'eval 'cond cond1) 44 | (put 'eval 'apply apply1) 45 | ) 46 | -------------------------------------------------------------------------------- /code/Chapter 4/e4-30: -------------------------------------------------------------------------------- 1 | ; a: 2 | ; all exps are delayed, so when they need to force, the order is right 3 | 4 | ; b: 5 | ; 1 6 | ; (1 2) 7 | 8 | ; (1 2) 9 | ; (1 2) 10 | 11 | ; c: 12 | ; because the order of exps is still right, just force first proc execute, comparing to origin version 13 | 14 | ; d: 15 | ; I like text version, I think we should keep delay as much as possible in order to be more efficient -------------------------------------------------------------------------------- /code/Chapter 4/e4-31: -------------------------------------------------------------------------------- 1 | ; tired, just describe the modifications. 2 | 3 | ; first, change analyze-define, tag arguments according to their tag 4 | ; second, change apply and eval, call different procs according to tag -------------------------------------------------------------------------------- /code/Chapter 4/e4-32: -------------------------------------------------------------------------------- 1 | ; as the footnote said, we can create lazy tree, which car and cdr are both lazy list. -------------------------------------------------------------------------------- /code/Chapter 4/e4-33: -------------------------------------------------------------------------------- 1 | (define (list . args) 2 | (if (null? args) 3 | '() 4 | (cons (car args) (list (cdr args))) 5 | ) 6 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-34: -------------------------------------------------------------------------------- 1 | (define (user-print L) 2 | (if (infinite? L) 3 | (display "try to display infinite object") 4 | (if (not (null? L)) 5 | (begin (display (actual-value (car L))) (user-print (cdr L))) 6 | ) 7 | ) 8 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-35: -------------------------------------------------------------------------------- 1 | (define (an-integer-between start end) 2 | (if (> start end) 3 | (amb) 4 | (amb start (an-integer-between (+ start 1) end)) 5 | ) 6 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-36: -------------------------------------------------------------------------------- 1 | ; because all three amb is infinite, so the machine will stay on the third amb forever, because it never reach the end thus never reach fail, thus no backward 2 | 3 | 4 | 5 | (define (a-pythagorean-triple-between low high) (let ((i (an-integer-between low high))) 6 | (let ((j (an-integer-between i high))) 7 | (let ((k (an-integer-between j high))) (require (= (+ (* i i) (* j j)) (* k k))) (list i j k))))) 8 | 9 | (define generate-all-triple 10 | (let ((i (an-integer-from 1))) 11 | (a-pythagorean-triple-between 0 i) 12 | ) 13 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-37: -------------------------------------------------------------------------------- 1 | ; it's correct, because we need to try less numbers -------------------------------------------------------------------------------- /code/Chapter 4/e4-38: -------------------------------------------------------------------------------- 1 | (define (multiple-dwelling) 2 | (let ((baker (amb 1 2 3 4 5))(cooper (amb 1 2 3 4 5)) 3 | (fletcher (amb 1 2 3 4 5)) (miller (amb 1 2 3 4 5)) 4 | (smith (amb 1 2 3 4 5))) 5 | (require 6 | (distinct? (list baker cooper fletcher miller smith))) 7 | (require (not (= baker 5))) 8 | 9 | (require (not (= cooper 1))) 10 | (require (not (= fletcher 5))) 11 | (require (not (= fletcher 1))) 12 | (require (> miller cooper)) 13 | (require (not (= (abs (- fletcher cooper)) 1))) 14 | (list (list 'baker baker) (list 'cooper cooper) 15 | (list 'fletcher fletcher) (list 'miller miller) 16 | (list 'smith smith)))) -------------------------------------------------------------------------------- /code/Chapter 4/e4-39: -------------------------------------------------------------------------------- 1 | ; it doesn't matter. because the list is generated firstly, and then tested through requirements. so whatever order will get the same result, because the order doesn't influence the generation process -------------------------------------------------------------------------------- /code/Chapter 4/e4-4: -------------------------------------------------------------------------------- 1 | (define (install-and-or) 2 | (define (eval-and exp env) 3 | (if ((get 'eval (caar exp)) (car exp) env) 4 | (if (null? (cdr exp)) 5 | ((get 'eval (caar exp)) (car exp) env) 6 | (eval-and (cdr exp) env) 7 | ) 8 | false 9 | ) 10 | ) 11 | (define (eval-or exp env) 12 | (if ((get 'eval (caar exp)) (car exp) env) 13 | ((get 'eval (caar exp)) (car exp) env) 14 | (if (null? (cdr exp)) 15 | false 16 | (eval-or (cdr exp) env) 17 | ) 18 | ) 19 | ) 20 | (put 'eval 'and eval-and) 21 | (put 'eval 'or eval-or) 22 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-40: -------------------------------------------------------------------------------- 1 | (define (multiple-dwelling) 2 | (let ((fletcher (amb 1 2 3 4 5))) 3 | (require (not (= fletcher 5))) 4 | (require (not (= fletcher 1))) 5 | (let ((cooper (amb 1 2 3 4 5))) 6 | (require (not (= cooper 1))) 7 | (require (not (= (abs (- fletcher cooper)) 1))) 8 | (let ((miller (amb 1 2 3 4 5))) 9 | (require (> miller cooper)) 10 | (let ((baker (amb 1 2 3 4 5))) 11 | (require (not (= baker 5))) 12 | (let ((smith (amb 1 2 3 4 5))) 13 | (require (distinct? (list baker cooper fletcher miller smith))) 14 | ) 15 | ) 16 | ) 17 | ) 18 | (list (list 'baker baker) (list 'cooper cooper) (list 'fletcher fletcher) (list 'miller miller) (list 'smith smith))) 19 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-41: -------------------------------------------------------------------------------- 1 | (define (multiple-dwelling) 2 | (map (lambda (fletcher) 3 | (if (and (not (= fletcher 5)) (not (= fletcher 1))) 4 | (map (lambda (cooper) 5 | (if (and (not (= fletcher 1)) (not (= (abs (- fletcher cooper)) 1))) 6 | (map (lambda (miller) 7 | (if (> miller cooper) 8 | (map (lambda (baker) 9 | (if (not (= baker 5)) 10 | (map (lambda (smith) 11 | (if (distinct? (list baker cooper fletcher miller smith)) 12 | (list fletcher cooper miller baker smith) 13 | ) 14 | ) (list 1 2 3 4 5)) 15 | ) 16 | ) (list 1 2 3 4 5)) 17 | ) 18 | ) (list 1 2 3 4 5)) 19 | ) 20 | ) (list 1 2 3 4 5)) 21 | ) 22 | ) (list 1 2 3 4 5)) 23 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-42: -------------------------------------------------------------------------------- 1 | ; each statement can create 2 list, for example, Betty: (kitty 2) (betty 3) 2 | ; true is 1, false is 0, 5 sentences can be formed as (0 0 0 0 0) which means first statement of 5 sentences are false, thus second statement is true. 3 | ; write a generater to create list from (0 0 0 0 0) to (1 1 1 1 1) 4 | ; then map through that list, combine all true statement, check whether distinct, if distinct, then check if conflict with false statement, if not, we find the answer -------------------------------------------------------------------------------- /code/Chapter 4/e4-43: -------------------------------------------------------------------------------- 1 | ; nest let and require 2 | ; each let use amb to guess a value, and the value is deleted from the possible set, then pass to next level let 3 | ; if we pass all require, we get the answer. 4 | ; 5 | ; the most important part is reduce possible set after each guess, thus we can be more efficient -------------------------------------------------------------------------------- /code/Chapter 4/e4-44: -------------------------------------------------------------------------------- 1 | (define (8queens) 2 | (let ((q1 (amb 1 2 3 4 5 6 7 8)) (q2 (amb 1 2 3 4 5 6 7 8)) (q3 (amb 1 2 3 4 5 6 7 8)) (q4 (amb 1 2 3 4 5 6 7 8)) (q5 (amb 1 2 3 4 5 6 7 8)) (q6 (amb 1 2 3 4 5 6 7 8)) (q7 (amb 1 2 3 4 5 6 7 8)) (q8 (amb 1 2 3 4 5 6 7 8))) 3 | (require 4 | (distinct? (list q1 q2 q3 q4 q5 q6 q7 q8))) 5 | 6 | (list q1 q2 q3 q4 q5 q6 q7 q8))) 7 | 8 | 9 | ; yes it's slow, we can change it to nested version, just don't want to write that because I need to write code for company -------------------------------------------------------------------------------- /code/Chapter 4/e4-45: -------------------------------------------------------------------------------- 1 | ; I'm not good at play english word game......forgive me, I know there are 5 different ways, good. -------------------------------------------------------------------------------- /code/Chapter 4/e4-46: -------------------------------------------------------------------------------- 1 | ; if it evaluate from right to left, maybe it will create infinite loop while evaluate right operand -------------------------------------------------------------------------------- /code/Chapter 4/e4-47: -------------------------------------------------------------------------------- 1 | ; this won't work, because second operand doesn't contain first operand, thus we will lose previous parsed part. 2 | 3 | ; if we change the order, it will create infinite loop, because first operand of amb will always call itself, thus we can't evaluate it -------------------------------------------------------------------------------- /code/Chapter 4/e4-48: -------------------------------------------------------------------------------- 1 | (define adjective '(adj good bad beautiful)) 2 | 3 | (define (parse-sentence) 4 | (list 'sentence (parse-adj-pharse) (parse-noun-phrase) (parse-verb-phrase))) 5 | 6 | (define (parse-adj-pharse) 7 | (list 'adj-pharse 8 | (parse-word adjective)) 9 | ) 10 | 11 | ; adverbs is the same -------------------------------------------------------------------------------- /code/Chapter 4/e4-49: -------------------------------------------------------------------------------- 1 | (define (parse-word word-list) 2 | (car word-list) 3 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-5: -------------------------------------------------------------------------------- 1 | (define (cond? exp) (tagged-list? exp 'cond)) 2 | 3 | (define (cond-clauses exp) (cdr exp)) 4 | 5 | (define (cond-else-clause? clause) 6 | (eq? (cond-predicate clause) 'else)) 7 | 8 | (define (cond-predicate clause) (car clause)) 9 | 10 | (define (cond-actions clause) (cdr clause)) 11 | 12 | (define (special? clause) (eq? '=> (cadr clause))) 13 | 14 | (define (cond-actions-special clause) (cons (cddr clause) (car clause))) 15 | 16 | (define (cond->if exp) 17 | (expand-clauses (cond-clauses exp))) 18 | 19 | (define (expand-clauses clauses) 20 | (if (null? clauses) 21 | 'false 22 | (let ((first (car clauses)) (rest (cdr clauses))) 23 | (if (cond-else-clause? first) 24 | (if (null? rest) 25 | (sequence->exp (cond-actions first)) 26 | (error "ELSE clause isn't last: COND->IF" 27 | clauses)) 28 | (if (special? first) 29 | (make-if (cond-predicate first) 30 | (sequence->exp (cond-actions first)) 31 | (expand-clauses rest)) 32 | (make-if (cond-predicate first) 33 | (sequence->exp (cond-actions first)) 34 | (expand-clauses rest)) 35 | ) 36 | )))) 37 | -------------------------------------------------------------------------------- /code/Chapter 4/e4-50: -------------------------------------------------------------------------------- 1 | (define (amb-choices exp) 2 | (define (random-in-range low high) 3 | (let ((range (- high low))) 4 | (+ low (random range)) 5 | ) 6 | ) 7 | (define (random-gen exp) 8 | (let ((index (random-in-range 1 (length exp)))) 9 | (define (iter left exp n) 10 | (if (= n index) 11 | (cons (cons left (cdr exp)) (car exp)) 12 | (iter (cons left (car exp)) (cdr exp) (+ n 1)) 13 | ) 14 | ) 15 | (iter '() exp 0) 16 | ) 17 | ) 18 | (define (random-choose exp) 19 | (if (null? exp) 20 | '() 21 | (let ((random-result (random-gen exp))) 22 | (cons (car random-result) (random-choose (cdr random-result))) 23 | ) 24 | ) 25 | ) 26 | (random-choose exp) 27 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-51: -------------------------------------------------------------------------------- 1 | ; if we use set!, the result will always be (x x 1) -------------------------------------------------------------------------------- /code/Chapter 4/e4-52: -------------------------------------------------------------------------------- 1 | (define (analyze-if-fail exp exp-fail) 2 | (let ((pproc (analyze (if-predicate exp))) (cproc (analyze (if-consequent exp)))) 3 | (lambda (env succeed fail) 4 | (pproc env 5 | ;; success continuation for evaluating the predicate ;; to obtain pred-value 6 | (lambda (pred-value fail2) 7 | pred-value) 8 | ;; failure continuation for evaluating the predicate 9 | (lambda () (cproc env succeed fail)))))) 10 | -------------------------------------------------------------------------------- /code/Chapter 4/e4-53: -------------------------------------------------------------------------------- 1 | ; result is (3 20) -------------------------------------------------------------------------------- /code/Chapter 4/e4-54: -------------------------------------------------------------------------------- 1 | (define (analyze-require exp) 2 | (let ((pproc (analyze (require-predicate exp)))) 3 | (lambda (env succeed fail) (pproc env 4 | (lambda (pred-value fail2) (if (false? pred-value) 5 | (fail2) 6 | (succeed 'ok fail2))) 7 | fail)))) -------------------------------------------------------------------------------- /code/Chapter 4/e4-55: -------------------------------------------------------------------------------- 1 | (supervisor ?x (Ben Bitdiddle)) 2 | 3 | (job ?x (accounting . ?job)) 4 | 5 | (and (address ?x (Slumerville . ?add)) 6 | (job ?x (accounting . ?job))) -------------------------------------------------------------------------------- /code/Chapter 4/e4-56: -------------------------------------------------------------------------------- 1 | (and (supervisor ?x (Ben Bitdiddle)) (address ?x (. ?add))) 2 | 3 | (and (salary (Ben Bitdiddle) ?amount1) (salary ?person ?amount) (lisp-value < ?amount ?amount1)) 4 | 5 | (and (supervisor ?x ?y) (not (job ?y (computer . ?job)))) -------------------------------------------------------------------------------- /code/Chapter 4/e4-57: -------------------------------------------------------------------------------- 1 | (rule (replace ?person1 ?person2) 2 | (and 3 | (or 4 | (and (job ?person1 ?job) (job ?person2 ?job)) 5 | (and (replace ?person1 ?person3) (replace ?person3 ?person2)) 6 | ) 7 | (not (same ?person1 ?person2)) 8 | ) 9 | ) 10 | 11 | (replace ?person (Cy D. Fect)) 12 | 13 | (and (replace ?person1 ?person2) (salary ?person1 ?amount1) (salary ?person2 ?amount2) (lisp-value < ?amount1 ?amount2)) -------------------------------------------------------------------------------- /code/Chapter 4/e4-58: -------------------------------------------------------------------------------- 1 | (rule (big-shot ?person) 2 | (and 3 | (job ?person (?division . ?job)) 4 | (supervisor ?person ?person2) 5 | (job ?person2 (?division2 . ?job2)) 6 | (not (same ?division ?division2)) 7 | ) 8 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-59: -------------------------------------------------------------------------------- 1 | (meeting ?x (Friday ?y)) 2 | 3 | (rule (meeting-time ?person ?day-and-time) 4 | (or 5 | (meeting whole-company ?day-and-time) 6 | (and 7 | (job ?person (?division . ?job)) 8 | (meeting ?division ?day-and-time) 9 | ) 10 | ) 11 | ) 12 | 13 | (meeting-time (Hacker Alyssa P) (Wednesday ?time)) -------------------------------------------------------------------------------- /code/Chapter 4/e4-6: -------------------------------------------------------------------------------- 1 | (define (let-vars clause) 2 | (map (lambda (x) (car x)) (cadr clause)) 3 | ) 4 | 5 | (define (let-exps clause) 6 | (map (lambda (x) (cdr x)) (cadr clause)) 7 | ) 8 | 9 | (define (let-body clause) 10 | (cddr clause) 11 | ) 12 | 13 | (define (eval-let exp env) 14 | ((make-lambda (let-vars exp) (let-body exp)) (let-exps exp)) 15 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-60: -------------------------------------------------------------------------------- 1 | ; because different order is consided as different result 2 | ; we can't do that, because we don't have states,thus unable to check whether the pair of different order has appeared before -------------------------------------------------------------------------------- /code/Chapter 4/e4-61: -------------------------------------------------------------------------------- 1 | (?x next-to ?y in (1 (2 3) 4)) 2 | 3 | ; (1 next-to (2 3) in (1 (2 3) 4)) 4 | ; ((2 3) next-to 4 in (1 (2 3) 4)) 5 | 6 | (?x next-to 1 in (2 1 3 1)) 7 | 8 | ; (2 next-to 1 in (2 1 3 1)) 9 | ; (3 next-to 1 in (2 1 3 1)) -------------------------------------------------------------------------------- /code/Chapter 4/e4-62: -------------------------------------------------------------------------------- 1 | (rule (last-pair ?x ())) 2 | 3 | (rule (last-pair (?u . ?v) ?v)) -------------------------------------------------------------------------------- /code/Chapter 4/e4-63: -------------------------------------------------------------------------------- 1 | (rule (grandson ?S ?G) 2 | (and 3 | (son ?S ?f) 4 | (son ?f ?G) 5 | ) 6 | ) 7 | 8 | (rule (son ?S ?M) 9 | (and 10 | (wife ?W ?M) 11 | (son ?S ?W) 12 | ) 13 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-7: -------------------------------------------------------------------------------- 1 | ; just add a clause to eval is sufficient, convert let* to nested let, thus will create new envs for each variable and use the previous variables -------------------------------------------------------------------------------- /code/Chapter 4/e4-8: -------------------------------------------------------------------------------- 1 | (define (let-vars clause) 2 | (map (lambda (x) (car x)) (cadr clause)) 3 | ) 4 | 5 | (define (let-exps clause) 6 | (map (lambda (x) (cdr x)) (cadr clause)) 7 | ) 8 | 9 | (define (let-body clause) 10 | (cddr clause) 11 | ) 12 | 13 | (define (let-define-var clause) 14 | (cadr clause) 15 | ) 16 | 17 | (define (eval-let exp env) 18 | (if (pair? (cadr exp)) 19 | ((make-lambda (let-vars exp) (let-body exp)) (let-exps exp)) 20 | (begin 21 | (define-variable! (let-define-var exp) (make-lambda (let-vars (cdr exp)) (let-body (cdr exp))) env) 22 | (((make-lambda (let-vars (cdr exp)) (let-body (cdr exp))) (let-exps exp)) (let-exps (cdr exp))) 23 | ) 24 | ) 25 | ) -------------------------------------------------------------------------------- /code/Chapter 4/e4-9: -------------------------------------------------------------------------------- 1 | (define (eval-for exp env) 2 | (let ((var (cadr exp)) (start (caddr exp)) (end (cadddr exp)) (body caddddr exp)) 3 | (define (iter var start) 4 | (if (> start end) 5 | 'ok 6 | (begin 7 | (define-variable! var start env) 8 | ((make-lambda var body) start) 9 | (iter var (+ start 1)) 10 | ) 11 | ) 12 | ) 13 | (iter var start) 14 | ) 15 | ) 16 | 17 | (for i 1 10 (display i)) -------------------------------------------------------------------------------- /code/Chapter 5/e5-11: -------------------------------------------------------------------------------- 1 | ; a: I don't know 2 | 3 | ; b: 4 | 5 | (define (make-save inst machine stack pc) 6 | (let ((reg (get-register machine 7 | (stack-inst-reg-name inst)))) 8 | (lambda () 9 | (push stack (cons (get-contents reg) reg)) (advance-pc pc)))) 10 | 11 | (define (make-restore inst machine stack pc) (let ((reg (get-register machine 12 | (stack-inst-reg-name inst)))) 13 | (lambda () 14 | (let ((value (pop stack))) 15 | (if (equal? (cdr stack) reg) 16 | (begin (set-contents! reg (pop stack)) (advance-pc pc)) 17 | (error "Different reg name when pop") 18 | ) 19 | )))) 20 | 21 | 22 | ; c: 23 | 24 | (define (init-reg-stacks) 25 | (map (lambda (reg) (list reg)) regs) 26 | ) 27 | 28 | (define (push-to x) 29 | (let ((val (assoc (car x) s))) 30 | (set! val (cons (cdr x) val)) 31 | ) 32 | ) 33 | 34 | (define (pop-from x) 35 | (let ((val (assoc (car x) s))) 36 | (let ((return (cdr val))) 37 | (set! val (cdr x)) 38 | return 39 | ) 40 | ) 41 | ) 42 | 43 | (define (make-stack) 44 | (let ((s '())) 45 | (define (push x) (set! s (push-to x))) 46 | (define (pop) 47 | (if (null? s) 48 | (error "Empty stack: POP") (pop-from x))) 49 | (define (initialize) 50 | (set! s (init-reg-stacks)) 51 | 'done) 52 | (define (dispatch message) 53 | (cond ((eq? message 'push) push) 54 | ((eq? message 'pop) (pop)) 55 | ((eq? message 'initialize) (initialize)) 56 | (else (error "Unknown request: STACK" message)))) 57 | dispatch)) 58 | -------------------------------------------------------------------------------- /code/Chapter 5/e5-12: -------------------------------------------------------------------------------- 1 | ; need to modify the analyze proc, just show the core part 2 | 3 | (define (add-reg r) 4 | (let ((val (assoc (car x) s))) 5 | (if (null? val) 6 | (set! regs (cons r regs)) 7 | ) 8 | ) 9 | ) 10 | 11 | ; others are the same. source is special, we neet to store a list for each regs -------------------------------------------------------------------------------- /code/Chapter 5/e5-13: -------------------------------------------------------------------------------- 1 | ; like previous exercise, just delete the regs arguments and call add-regs each time meet a reg -------------------------------------------------------------------------------- /code/Chapter 5/e5-14: -------------------------------------------------------------------------------- 1 | (define factorial-machine 2 | (make-machine '(n val continue) (list (list '= =) (list '- -) (list '* *)) '( 3 | fact-loop 4 | (assign continue (label fact-loop)) 5 | (assign b (op read)) 6 | (test (op =) (reg n) (const 1)) 7 | (branch (label base-case)) 8 | (save continue) 9 | (save n) 10 | (assign n (op -) (reg n) (const 1)) 11 | (assign continue (label after-fact)) 12 | (goto (label fact-loop)) 13 | after-fact 14 | (restore n) 15 | (restore continue) 16 | (assign val (op *) (reg n) (reg val)) 17 | (print-statistic) 18 | (goto (reg continue)) 19 | base-case 20 | (assign val (const 1)) 21 | (print-statistic) 22 | (goto (reg continue))))) 23 | 24 | (start-machine factorial-machine) -------------------------------------------------------------------------------- /code/Chapter 5/e5-15: -------------------------------------------------------------------------------- 1 | ; new message 2 | 3 | (define (print-and-reset) 4 | (display pc-number) 5 | (set! pc-number 0) 6 | ) 7 | 8 | ((eq? m 'print-and-reset) (print-and-reset)) 9 | 10 | ; add pc-number in execute 11 | 12 | ... 13 | (set! pc-number (+ 1 pc-number)) 14 | ... 15 | 16 | -------------------------------------------------------------------------------- /code/Chapter 5/e5-16: -------------------------------------------------------------------------------- 1 | ; new message 2 | 3 | ((eq? m 'trace-on) (set! trace true)) 4 | ((eq? m 'trace-off) (set! trace false)) 5 | 6 | ; before execute 7 | 8 | ... 9 | (if trace 10 | (display inst) 11 | ) 12 | ... -------------------------------------------------------------------------------- /code/Chapter 5/e5-17: -------------------------------------------------------------------------------- 1 | ; add another state to store label 2 | 3 | ; when meet label 4 | 5 | (set! last-label label) 6 | 7 | ; when execute inst 8 | 9 | ... 10 | (if last-label (display last-label)) 11 | ;;execute inst 12 | ... 13 | (set! last-label false) 14 | ... -------------------------------------------------------------------------------- /code/Chapter 5/e5-18: -------------------------------------------------------------------------------- 1 | ; add a local state to reg 2 | 3 | ((eq? m 'trace-on) (set! trace true)) 4 | ((eq? m 'trace-off) (set! trace false)) 5 | 6 | ; before assign 7 | 8 | ... 9 | (if trace 10 | (display reg oldvalue newvalue) 11 | ) 12 | ... -------------------------------------------------------------------------------- /code/Chapter 5/e5-19: -------------------------------------------------------------------------------- 1 | ; when set breakpoint, add it to breakpoint list 2 | 3 | (define (set-breakpoint machine label n) 4 | (set! breakpoints (cons (cons label n) breakpoints)) 5 | ) 6 | 7 | ; before execute each inst, check whether reach the breakpoint 8 | 9 | ... 10 | (if (reach-breakpoint inst) 11 | (driver-loop) 12 | ) 13 | 14 | ; driver loop will receive messages 15 | 16 | (define (driver-loop) 17 | (let ((m (read))) 18 | (cond 19 | ((eq? m 'set....) (set...) (driver-loop)) 20 | ((eq? m 'get....) (get...) (driver-loop)) 21 | ((eq? m 'set....) (proceed...)) 22 | ) 23 | ) 24 | ) 25 | 26 | ; for proceed, just exit loop and back to normal insts 27 | 28 | ; for cancel-breakpoints, lookup and delete it from breakpoints -------------------------------------------------------------------------------- /code/Chapter 5/e5-20: -------------------------------------------------------------------------------- 1 | ; final value is p3 2 | 3 | ; p1 is x, p2 is y 4 | 5 | ; | p1 | p2 | 6 | ; | 1 | p1 | 7 | ; | 2 | p1 | -------------------------------------------------------------------------------- /code/Chapter 5/e5-21: -------------------------------------------------------------------------------- 1 | ; same as fib, two recursives, just use pair operations -------------------------------------------------------------------------------- /code/Chapter 5/e5-22: -------------------------------------------------------------------------------- 1 | (assign reg1 (op append) (reg l1) (reg l2)) 2 | 3 | ;implements as: 4 | 5 | (perform 6 | (op vector-set!) (reg the-cars) (reg free) (reg l1)) 7 | (perform 8 | (op vector-set!) (reg the-cdrs) (reg free) (reg l2)) 9 | (assign reg1 (reg free)) 10 | (assign free (op +) (reg free) (const 1)) 11 | 12 | 13 | (assign (op append!) (reg l1) (reg l2)) 14 | 15 | ;implements as: 16 | 17 | (perform 18 | (op vector-set!) (reg the-cars) (reg l1) (reg l1)) 19 | (perform 20 | (op vector-set!) (reg the-cdrs) (reg l1) (reg l2)) 21 | 22 | -------------------------------------------------------------------------------- /code/Chapter 5/e5-23: -------------------------------------------------------------------------------- 1 | ev-cond 2 | (assign unev (op cond-if) (reg exp)) 3 | (goto (label eval-dispatch)) 4 | ; after dispatch, it will goto the place called ev-cond -------------------------------------------------------------------------------- /code/Chapter 5/e5-24: -------------------------------------------------------------------------------- 1 | ev-cond 2 | (assign unev (reg exp)) 3 | (assign exp (op first-cond) (reg unev)) 4 | (test (op last-cond?) (reg exp)) 5 | (branch (label-last-cond)) 6 | (assign unev (op rest-cond) (reg unev)) 7 | (test (op last-cond?) (exp)) 8 | (save exp) 9 | (assign proc (op get-body) (reg exp)) 10 | (assign exp (op get-test) (reg exp)) 11 | (save env) 12 | (save unev) 13 | (save proc) 14 | (save continue) 15 | (assign continue (label cond-1)) 16 | (goto (eval-dispatch)) 17 | cond-1 18 | (restore continue) 19 | (restore proc) 20 | (restore unev) 21 | (restore env) 22 | (restore exp) 23 | (test (op true?) val) 24 | (branch ev-cond) 25 | (assign env proc) 26 | (goto (label ev-sequence)) 27 | last-cond 28 | (assign exp (op get-body) (reg exp)) 29 | (goto (label ev-sequence)) -------------------------------------------------------------------------------- /code/Chapter 5/e5-25: -------------------------------------------------------------------------------- 1 | ; same strategy as lazy evaluator, just eval the value if we must use it -------------------------------------------------------------------------------- /code/Chapter 5/e5-31: -------------------------------------------------------------------------------- 1 | ; env of operator 2 | ; env of operand 3 | ; argl of operand 4 | ; proc of operand 5 | 6 | (f 'x 'y) 7 | ; ignore: env of operator, env of operand, proc of operand, argl of operand 8 | 9 | ((f) 'x 'y) 10 | ; ignore: env of operand, proc of operand, argl of operand 11 | 12 | (f (g 'x) y) 13 | ; ignore: env of f, env of g, env of 'x, proc of 'x, argl of 'x 14 | 15 | (f (g 'x) 'y) 16 | ; ignore: env of f, env of g, env of 'x, proc of 'x, argl of 'x, argl of f, env of 'y -------------------------------------------------------------------------------- /code/Chapter 5/e5-32: -------------------------------------------------------------------------------- 1 | ; a: just and one more test 2 | 3 | ; b: I don't think so. recognizing special cases has costs by itself, more tests will be more inefficient. and it will be harder to modify the compiler, also make it less general -------------------------------------------------------------------------------- /code/Chapter 5/e5-33: -------------------------------------------------------------------------------- 1 | ; exercise version will save only n, but text version will save argl, which is a list, thus is inefficient -------------------------------------------------------------------------------- /code/Chapter 5/e5-34: -------------------------------------------------------------------------------- 1 | ; it's too hard to write all compiled code by hand...... 2 | 3 | ; iterative version doesn't need to save and restore on each call, just overwrite the value -------------------------------------------------------------------------------- /code/Chapter 5/e5-35: -------------------------------------------------------------------------------- 1 | (define (f x) 2 | (+ x (g (+ x 2))) 3 | ) -------------------------------------------------------------------------------- /code/Chapter 5/e5-36: -------------------------------------------------------------------------------- 1 | ; right-to-left 2 | 3 | ; construct-arglis procedure 4 | 5 | ; if we construct from left-to-right, we have to use append, which is slower than cons -------------------------------------------------------------------------------- /code/test: -------------------------------------------------------------------------------- 1 | (define (coerce-to x) 2 | (if (< x 3) 3 | x 4 | false 5 | ) 6 | ) 7 | 8 | (filter (lambda (x) x) (map coerce-to '(1 2 3 4 5))) -------------------------------------------------------------------------------- /sicp.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/numbbbbb/sicp/4afae97c9d56ad283242ff271237d99e238e063f/sicp.pdf --------------------------------------------------------------------------------