SICP 题解（现至第三章）
耗时一个月，全部独立完成，部分比较简单的题目没用给出题解。一般只给出代码，比较难或者有趣的题目会给出分析。
使用 DrRacket 的语言库 #lang sicp 作为解释器，除了部分难以给出题设环境的、涉及语言具体实现的、和使用一些省略（....）的题解，一般都是可以运行的。
Building Abstractions with Procedures
两种求值顺序
-
normal order
非必要不对操作数求值
-
applicative order
先把参数计算出来再应用到过程中
将过程视为隐藏了具体实现的黑盒，只提供接口。
变量的绑定和作用域。
迭代过程维护固定数量的状态变量；递归过程则需要保留一部分数据，延后进行一些操作（对应栈的延伸和缩减）。正如迭代过程可以使用表面上的递归（也就是调用自身）的方法实现，递归过程也可以用迭代的方法实现，比如在命令式语言中可以不显式地调用自身，但在迭代的过程中也会出现空间的增长，此时诸如 do for while repeat 等操作其实都是递归过程的迭代语法糖。
Exercise
1.5
(define (p) (p))
(define (test x y)
(if (= x 0) 0 y))
(test 0 (p))
Scheme 使用 applicative-order 的求值过程, 也就是说先对操作数求值。两个操作数 0 (p) 第一个已经是无法进一步求值的常数了，所以对 (p) 求值，这是一个（尾递归地）调用自身的函数，因此既不会停止但也不会爆栈，相当于 C 类语言的 for (;;);。
像 Haskell 这样 normal-order 求值的语言，则不会卡住
test :: (Eq a1, Num a1, Num a2) => a1 -> a2 -> a2
test 0 _ = 0
test x y = y
p :: t
p = p
x :: Integer
x = test 0 p
1.6
(define (new-if predicate then-clause else-clause)
(cond [predicate then-clause]
[else else-clause]))
(define (sqrt-iter guess x) ; stack burst
(new-if (good-enough? guess x)
guess
(sqrt-iter (improve guess x) x)))
Scheme 自带的 if 是宏，而定义的 new-if 则是函数，因此 if 不会计算 then else 子句，new-if 则会计算。使用 new-if 的 sqrt-iter 不管 good-enough? 是否成立都会调用子过程 sqrt-iter，导致栈溢出。
1.7
使用 guess 的变化来计算截至值。
(define (good-enought? guess x)
(< (abs (- guess
(/ x guess)))
0.001))
1.8
牛顿法计算立法根
(define (cube-root x)
(define (close? a b)
(< (abs (- a b))
0.001))
(define (better-approx y)
(/ (+ (/ x y y)
(* 2 y))
3))
(let iter ([guess 1])
(let ([next (better-approx guess)])
(if (close? guess next)
next
(iter next)))))
1.9
(define (+ a b) ; recursive process
(if (= a 0) b (inc (+ (dec a) b))))
(define (+ a b) ; iterative process
(if (= a 0) b (+ (dec a) (inc b))))
1.10
\[\begin{align*}
f(n)&=2n\\[0.7em]
g(n)&=2^n\\
h(n)&=\underbrace{2^{2^{\cdot^{\cdot^{\cdot^2}}}}}_n
\end{align*}
\]
count-change
设硬币种类为 n， 可以使用 n 个数组 a 保存结果，其中第 i 个数组保存只使用第 i 个之前的硬币种类得到的兑换数。则 a[i,j] 表示只使用第 i 个之前的硬币种类兑换 j 的结果。用 c[k] 表示第 k 种硬币的大小。
\[\begin{align*}
a[i,j]=\begin{cases}
0&i<0\vee j<0\\
1&i=0\vee j=0\\
a[i,j-c[i]]+a[i-1,j]&\text{else}
\end{cases}
\end{align*}
\]
1.11
(define (f n) ; recursive
(if (< n 3)
n
(+ (f (- n 1))
(* (f (- n 2)) 2)
(* (f (- n 3)) 3))))
(define (f n) ; iterative
(if (< n 3)
n
(let iter ([f_c-2 0]
[f_c-1 1]
[f_c 2]
[c 2])
(if (= c n)
f_c
(iter f_c-2
f_c-1
(+ f_c
(* 2 f_c-1)
(* 3 f_c-2))
(inc c))))))
1.12
(define (pascal-triangle row col)
(cond [(or (< row 0)
(< col 0)
(> col row))
(error "invalid arguments")]
[(or (= col 1)
(= col row))
1]
[else (let ([row (dec row)])
(+ (pascal-triangle row col)
(pascal-triangle row (dec col))))]))
1.13
1.14
由 count-change 一节可得若硬币种类为 m，金额为 \(n\)，则空间时间复杂度为 \(O(mn)\)，这是线性算法的情况。
对于树形算法 \(f(m,n)=\begin{cases}\Theta(1)&m\le0\vee n\le0\\f(m,n-c[m])+f(m-1,n)&m,n>0\end{cases}\)，可能涉及到一部分重复计算。
1.15
\[\begin{align*}
\sin x=3\sin\frac x3-4\sin\frac x3
\end{align*}
\]
递归次数约为 \(\lceil\log_310x\rceil\)，使用尾递归空间复杂度为常数，若认为 (p x) (cube x) 等时间复杂度为常数，则 (sine x) 时间复杂度为 \(O(\lg x)\)。
1.16
实际上就是分解 n 的二进制，对应 \(b,b^2,b^4,\ldots\)，用 b^k 记录。
(define (iter-expt b n)
(cond [(= n 0) 1]
[(< n 0) (/ 1 (iter-expt b (- n)))]
[else (let iter ([b^k b]
[n n]
[a 1])
(let ([q (quotient n 2)]
[r (remainder n 2)]
[b^2k (* b^k b^k)])
(cond [(= n 0) a]
[(= r 1) (iter b^2k
q
(* a b^k))]
[else (iter b^2k
q
a)]))))
1.17 1.18
将 1.16 改为 \(b,2b,4b,\ldots\)，因为乘法和指数实际上只差一个 \(\log,\exp\)。
(define (fast-mul a b)
(cond [(= b 0) 0]
[(< b 0) (- (fast-mul a (- b)))]
[else (let ([q (quotient b 2)]
[r (remainder b 2)])
(let ([next (fast-mul (* 2 a)
q)])
(if (= r 1)
(+ a next)
next)))]))
(define (iter-mul a b)
(cond [(= b 0) 0]
[(< b 0) (- (iter-mul a (- b)))]
[else (let iter ([a a]
[b b]
[result 0])
(let ([q (quotient b 2)]
[r (remainder b 2)]
[2a (* 2 a)])
(cond [(= b 0) result]
[(= r 1) (iter 2a
q
(+ a result))]
[else (iter 2a q result)])))]))
1.19
Python 的实现和 Scheme 的实现
def fib(n, dtype=sympy.Integer):
one, zero = dtype(1), dtype(0)
a, b, p, q = zero, one, one, zero
while n:
if n & 1:
ap = a * p
a, b = ap + a*q + b*p, ap + b*q
pp = p * p
p, q = pp + 2*p*q, pp + q*q
n >>= 1
return a
(define (fib n)
(let iter ([a 0] [b 1] [p 1] [q 0] [n n])
(cond [(= n 0) a]
[(= (remainder n) 0)
(iter a
b
(+ (* p p) (* 2 p q))
(+ (* p p) (* q q))
(quotient n 2))]
[else (iter (+ (* a p) (* a q) (* b p))
(+ (* a p) (* b q))
p
q
(- n 1))])))
1.25
(define (expmod base exp m)
(cond [(= exp 0) 1]
[(even? exp)
(remainder
(square (expmod base (quotient exp 2) m))
m)]
[else
(remainder
(* base (expmod base (dec exp) m))
m)]))
(define (expmod base exp m)
(remainder (fast-expt base exp) m))
第一个版本在每次递归时就进行了一次取模，\((km+n)^2\mod m=n^2\mod m\)，结果相同，但是数字更小因此计算量更也小。
1.26
\(T(n)=T(n/2)+O(1)\) 变为了 \(T(n)=2T(n/2)+O(1)\)。
1.28
(define (expmod base exp m)
(cond [(= (remainder (square base) m) 1) 0]
[(= exp 0) 1]
[(even? exp) (remainder
(square (expmod
base
(quotient exp 2)
m))
m)]
[else (remainder
(* base (expmod
base
(dec exp)
m))
m)]))
(define (fermat-test n a)
(define result (expmod a (dec n) n))
(= result 1))
1.29
(define (integral f a b)
(let* ([2n (* 2.0 100)]
[h (/ (- b a) 2n)])
(let ([y_0 (f a)] [y_2n (f b)])
(* h 1/3
(+ y_0 (- y_2n)
(let iter ([k 1] [sum 0])
(if (= k (+ 2n 1))
sum
(let* ([x1 (+ a (* k h))]
[x2 (+ x1 h)]
[y_x1 (f x1)]
[y_x2 (f x2)])
(iter (+ 2 k)
(+ sum
(* 4 y_x1)
(* 2 y_x2)))))))))))
1.30
(define (sum term a next b)
(let iter ([a a] [result 0])
(if (> a b)
result
(iter (next a) (+ result (term a))))))
1.31
(define (product term a next b)
(let iter ([a a] [result 1])
(if (> a b)
result
(iter (next a) (* result (term a))))))
(define (factorial n)
(define (self x) x)
(product self 1 inc n))
(define (get-π accuracy) ; recommand accuracy > 1000000000
(define (term n)
(/ (* (inc n) (dec n))
n n))
(define (next n) (+ 2 n))
(* 4 (product term 3.0 next accuracy)))
1.32
(define (accumulate combiner null-value term a next b)
(let iter ([a a] [result null-value])
(if (> a b)
result
(iter (next a) (combiner result (term a))))))
(define (product term a next b)
(accumulate * 1 term a next b))
(define (sum term a next b)
(accumulate + 0 term a next b))
1.33
(define (filtered-accumulate combiner null-value filter term a next b)
(let iter ([a a] [result null-value])
(cond [(> a b) result]
[(filter a)
(iter (next a) (combiner result (term a)))]
[else
(iter (next a) result)])))
(define (prime-square-sum-in-range a b)
(filtered-accumulate + 0 prime? square a inc b))
(define (product-of-positives-prime-to-n n)
(define (relatively-prime? i)
(= (gcd i n) 1))
(filtered-accumulate * 1 relatively-prime? self a inc b))
1.34
(f f) -> (f 2) -> (2 2) ; raise error
1.35
(define (fixed-point f first-guess)
(define tolerance 0.00001)
(define (close-enough? v1 v2)
(< (abs (- v1 v2))
tolerance))
(let iter ([guess first-guess])
(let ([next (f guess)])
(if (close-enough? guess next)
next
(iter next)))))
(define φ (fixed-point
(lambda (x) (+ 1 (/ x)))
1.0))
1.36
(define (fixed-point f first-guess)
(define tolerance 0.00001)
(define (close-enough? v1 v2)
(< (abs (- v1 v2))
tolerance))
(let iter ([guess first-guess])
(let ([next (f guess)])
(display guess)
(newline)
(if (close-enough? guess next)
next
(iter next)))))
(define x (fixed-point
(lambda (x) (log 1000 x))
(exp 1)))
1.37
(define (cont-frac n d k)
(let recu ([c 1])
(let ([n_c (n c)]
[d_c (d c)])
(if (= c k)
(/ n_c d_c)
(/ n_c (+ d_c (recu (inc c))))))))
(define (cont-frac n d k)
(let iter ([k k]
[result 0])
(if (= k 0)
result
(iter (dec k)
(/ (n k) (+ (d k) result))))))
1.38
(define (get-e k) ; recommend k > 5
(define (n _) 1.0)
(define (d i)
(let ([i (inc i)])
(let ([q (quotient i 3)]
[r (remainder i 3)])
(if (= r 0) (* 2.0 q) 1.0))))
(+ 2 (cont-frac n d 100)))
1.39
(define (tan-cf x k) ; recommend k > 1000
(define -x^2 (- (* x x)))
(define (n _) -x^2)
(define (d i) (+ 1.0 (* 2 i)))
(/ x (+ 1.0 (cont-frac n d k))))
1.40
(define ((cubic a b c) x)
(+ (* x x x)
(* a x x)
(* b x)
c))
1.41
(define ((double f) x)
(f (f x)))
1.42
(define ((compose f g) x)
(f (g x)))
1.43
(define ((repeated f n) x)
(if (< n 1)
(error "n should be positive" n)
(let iter ([count 1] [x (f x)])
(if (= count n)
x
(iter (inc count) (f x))))))
1.44
(define ((smooth f) x)
(define dx 1e-6)
(/ (+ (f (- x dx))
(f x)
(f (+ x dx)))
3))
(define (n-fold-smooth f n)
(repeated (smooth f) n))
1.45
求解 \(f(x)=x\)，可设 \(g(x)={x+f(x)\over2}\)，则 \(g(x)\) 的不动点 \(g(x)=x\) 满足 \(f(x)=x\)。而要通过 \(g(g(\cdots(g(x))\cdots))\) 来寻找不动点，用形象化的方法来说明这个迭代过程的收敛条件则是“\(g(x)\) 与 \(y=x\) 在不动点附近的夹角为锐角”。牛顿迭代法
若进行 \(n\) 次 \(g(x)={x+f(x)\over2}\)，得到 \(g_n(x)={(2^n-1)x+f(x)\over2^n}\)，\(f(n)\) 的成分减少，\(x\) 的成分增加，说明更加靠近 \(y=x\) 了，因此 \(g_n(x)\) 与 \(y=x\) 的夹角减小了。
对于 \(f(x)=y/x^{p-1}\)，其不动点为 \(x=\sqrt[p]y\)，\(g_n(x)\) 的不动点也为 \(\sqrt[p]y\)，斜率为 \(g_n^\prime(\sqrt[n]y)=1-p/2^n\)，令其 \(>-1\)（夹角为锐角），得 \(n>\log_2p-1\)，不妨取 \(n=\lfloor\log_2p\rfloor\)。
此外，还需要论证在不满足锐角的部分要收敛到满足锐角的部分。\(g_n^\prime(x)=1-[(p-1)y/x^p+1]/2^n\)，在 \(x\in(0,+\infty)\) 上为递增，唯一零点为 \(x_0=\sqrt[p]{{y(p-1)\over2^n-1}}\)，故 \(g_n(x)\) 为凸函数，只需要令 \(x\in(0,\sqrt[p]y)\) 经过多次 \(g_n(x)\) 计算后收敛到 \(\sqrt[p]y\) 即可。
对于 \(x\in(0,\sqrt[p]y)\)：
- 若 \(g_n^\prime(x)\ge-1\)，则已经进入收敛区域；
- 若 \(g_n^\prime(x)<-1\)，则可得 \(x<\sqrt[p]{{y(p-1)\over2^{n+1}-1}}<x_0\)，又 \(g_n(x)\) 在 \((0,x_0)\) 上递减，由 \(2^{n+1}>p\) 可得 \(g_n(x)>1/\sqrt[p]y\)，即下一步迭代为 \(x>1/\sqrt[p]y\)，得 \(g_n^\prime(x)>-1\)，同样进入收敛区域。
则 \(p=2,3\implies n=1\)，\(p=4\implies n=2\)，与题设相符。
(define (root y p)
(define n (inexact->exact (floor (log p 2))))
(define (f x) (/ y (exp (* (dec p)
(log x)))))
(fixed-point ((repeated average-damp n) f) 1.0))
(define (root y p) ; simplified
(define n (inexact->exact (floor (log p 2))))
(define (f x) (/ y (expt x (dec p))))
(define (g x)
(let ([m (expt 2 n)])
(/ (+ (* (dec m) x)
(f x))
m)))
(fixed-point g 1.0))
1.46
(define ((iterative-improve good-enough? improve) guess)
(let iter ([guess guess])
(let ([next (improve guess)])
(if (good-enough? guess next)
next
(iter next)))))
(define (sqrt x)
(define (close-enough? a b)
(< (abs (- a b)) 1e-5))
(define (improve guess)
(/ (+ guess
(/ x guess))
2))
((iterative-improve close-enough? improve) 1.0))
(define (fixed-point f first-guess)
(define (close-enough? a b)
(< (abs (- a b)) 1e-5))
(define improve f)
((iterative-improve close-enough? improve) first-guess))
Building Abstractions with Data
将数据的实现和应用分离，在实现的时候暴露数据的（统一的）接口给可能的应用。
数据 = 【构造（为抽象）+（从接口）应用】\(\times\) 符合抽象的含义。
可以使用 \(\lambda\) 演算等价地实现类型。
将对序列的操作归纳为 enumerate, map, filter, foldl, foldr 这几种泛用的接口。
符号就是表达式本身的形式，不会被自动演算。比如函数的参数就可以看作一种符号 (lambda (x) (+ x (+ 1 1)))，得到这个函数时，函数体中的 x （和 (+ 1 1)）并不会被演算。只有当调用这个函数时，相当于为符号注入了活力，使符号有了它所代表的某个值，函数才会开始运行。在 Lisp 中，符号用 ' 显式地声明。
data-directed style，使用 (get ⟨op⟩ ⟨type⟩)、(put ⟨op⟩ ⟨type⟩ ⟨item⟩) 作为接口，为数据赋予类型，并在计算时通过判断类型来选择不同的应用函数。对于构造函数 constructor，<type> 是构造函数的结果的类型；对于选择函数 selector，<type> 是函数参数的类型。
message-passing-style，将类型实现为一个函数，这个函数接受属性名和方法名并返回对应结果。
Exercise
2.1
(define (make-rat n d)
(let* ([g (abs (gcd n d))]
[g (if (negative? d) (- g) g)])
(cons (/ n g) (/ d g))))
2.2
(define (make-point x y)
(cons x y))
(define (x-point p) (car p))
(define (y-point p) (cdr p))
(define (midpoint p q)
(make-point (average (x-point p)
(x-point q))
(average (y-point p)
(y-point q))))
(define (print-point p)
(newline)
(display "(")
(display (x-point p))
(display ",")
(display (y-point p))
(display ")"))
(define (make-segment start end)
(cons start end))
(define (start-segment s) (car s))
(define (end-segment s) (cdr s))
(define (midpoint-segment s)
(midpoint (start-segment s)
(end-segment s)))
(define (print-segment s)
(print-point (start-segment s))
(newline)
(display "-->")
(print-point (end-segment s)))
2.3
; modifiy at construction time
(define (make-rect p1 p2)
(let ([x1 (x-point p1)]
[x2 (x-point p2)]
[y1 (y-point p1)]
[y2 (y-point p2)])
(let ([x1 (min x1 x2)]
[x2 (max x1 x2)]
[y1 (min y1 y2)]
[y2 (max y1 y2)])
(let ([p1 (make-point x1 y1)]
[p2 (make-point x2 y2)])
(cons p1 p2)))))
(define (left rect) (x-point (car rect)))
(define (right rect) (x-point (cdr rect)))
(define (top rect) (y-point (cdr rect)))
(define (bottom rect) (y-point (car rect)))
(define (width rect) (- (right rect) (left rect)))
(define (height rect) (- (top rect) (bottom rect)))
(define (perimeter rect)
(* 2 (+ (width rect) (height rect))))
(define (area rect)
(* (width rect) (height rect)))
; modify at selection time
(define (make-rect p1 p2)
(cons p1 p2))
(define (left rect)
(min (x-point (car rect))
(x-point (cdr rect))))
(define (right rect)
(max (x-point (car rect))
(x-point (cdr rect))))
(define (top rect)
(max (y-point (cdr rect))
(y-point (car rect))))
(define (bottom rect)
(min (y-point (cdr rect))
(y-point (car rect))))
(define (width rect) (- (right rect) (left rect)))
(define (height rect) (- (top rect) (bottom rect)))
(define (perimeter rect)
(* 2 (+ (width rect) (height rect))))
(define (area rect)
(* (width rect) (height rect)))
2.4
可以看我的另一篇笔记 Lambda 演算编程
(define (true t f) t)
(define (false t f) f)
(define (not a) (a false true))
(define (and b c) (b c false))
(define (or b c) (b true c))
(define ((cons f s) b) (b f s))
(define (car p) (p true))
(define (cdr p) (p false))
2.5
(define (cons a b) (* (expt 2 a)
(expt 3 b)))
(define (car p)
(let iter ([p p] [result 0])
(let ([q (quotient p 2)]
[r (remainder p 2)])
(if (= r 0)
(iter q (inc result))
result))))
(define (cdr p)
(inexact->exact (log (/ p (expt 2 (car p)))
3)))
2.6
也可以看我的这一篇笔记 Lambda 演算编程
(define ((zero f) x) x)
(define ((one f) x) (f x))
(define (two f) (repeated f 2))
(define (three f) (repeated f 3))
(define (four f) (repeated f 4))
(define (((succ n) f) x) (f ((n f) x)))
(define (((+ m n) f) x) ((m succ) n))
(define (((* m n) f) x) ((m (lambda (p) (+ n p)))
0))
2.10
(define (div-interval x y)
(let ([ub (upper-bound y)]
[lb (lower-bound y)])
(if (or (<= lb 0) (>= ub 0))
(error "interval spans zero" y)
(mul-interval
x
(make-interval (/ 1.0 ub)
(/ 1.0 lb))))
2.11
(define (mul-interval x y)
(define (cd ub lb)
(cond [(and (< ub 0) (< lb 0)) -1]
[(and (> ub 0) (> lb 0)) 1]
[else 0]))
(let ([ubx (upper-bound x)]
[lbx (lower-bound x)]
[uby (upper-bound y)]
[lby (lower-bound y)])
(cond [...])))
; only condition (= 0 (cd ubx lbx) (cd uby lby))
; requires more than two multiplications
2.12
(define (make-center-percent c p)
(let ([w (* c p)])
(make-center-width c w)))
(define (percent i)
(let ([c (center i)]
[w (width i)])
(/ w c)))
2.13
\[\begin{align*}
\text{given that}&&p&\text{ is small}\\
&&i_1&:=(1-p_1)c_1\sim(1+p_1)c_1\\
&&i_2&:=(1-p_2)c_2\sim(1+p_2)c_2\\
\text{then}&&i_1\times i_2&=(1-p_1)(1-p_2)c_1c_2\sim(1+p_1)(1+p_2)c_1c_2\\
&&&=(1-p_1-p_2+p_1p_2)c_1c_2\sim(1+p_1+p_2+p_1p_2)c_1c_2\\
&&&\xlongequal{p_1p_2\to0}(1-p_1-p_2)c_1c_2\sim(1+p_1+p_2)c_1c_2\\
\text{therefore}&&i&=i_1\times i_2=\operatorname{make-center-percent}(c_1c_2,p_1+p_2)
\end{align*}
\]
2.14 2.15 2.16
\[\begin{align*}
{R_1R_2\over R_1+R_2},{1\over1/R_1+1/R_2}
\end{align*}
\]
两个公式在使用 interval 计算时，第一个公式的 \(R_1R_2,R_1+R_2\) 的上下限是分开计算的，mul-interval 的结果的上下限不一定分别是 \(R_1,R_2\) 的上下限，而 add-interval 的结果则一定是 \(R_1,R_2\) 的上下限。因此第二个公式能够产生更严格的结果。
一般来说，加法上下限是对应的，减法的上下限是相反的，乘法的上下限是不确定的，除法的上下限是下上限的倒数。重点是要保证相同符号的上下限的计算不能分离。更一般的话，公式是 \(r\) 的任意次多项式，相当于求 \(\begin{cases}\max\\\min\end{cases}\sum_{k=0}^na_kr^k\text{ s.t. }r\in[l,u]\)，需要求定义域内每个极值和上下限的值，工作量是比较大的。但是如果能够采用更简单的模型，比如将电阻模型简化为只有串联和并联两种操作，并只提供这两种方法的接口，就可以更简单地实现了。
2.17
(define (last-pair lst)
(let iter ([lst lst])
(let ([tail (cdr lst)])
(if (null? tail)
lst
(iter tail)))))
2.18
(define (reverse lst)
(if (null? lst)
nil
(let iter ([lst lst] [result nil])
(let ([head (car lst)] [tail (cdr lst)])
(let ([result (cons head result)])
(if (null? tail)
result
(iter tail result)))))))
2.19
(define us-coins (list 50 25 10 5 1))
(define uk-coins (list 100 50 20 10 5 2 1 0.5))
(define (cc amount coin-values)
(cond [(= amount 0) 1]
[(or (< amount 0) (no-more? coin-values)) 0]
[else (+ (cc amount
(except-first-denomination
coin-values))
(cc (- amount
(first-denomination
coin-values))
coin-values))]))
(define (first-denomination coin-values)
(car coin-values)) ; define first-denomination car
(define (except-first-denomination coin-values)
(cdr coin-values)) ; define except-first-denomination cdr
(define (no-more? coin-values)
(null? coin-values)) ; define no-more? null?
2.20
(define (same-parity x . xs)
(let ([e (even? x)])
(let iter ([xs xs] [reversed-result (list x)])
(if (null? xs)
(reverse reversed-result)
(let ([x (car xs)] [xs (cdr xs)])
(if (eq? e (even? x))
(iter xs (cons x reversed-result))
(iter xs reversed-result)))))))
2.21
(define (square-list items)
(if (null? items)
nil
(cons (square (car items))
(square-list (cdr items)))))
(define (square-list items)
(map square items))
2.22
Scheme 的 list 使用只有头节点的单链表，因此一般来说添加元素只能在最前端添加。
2.23
(define (for-each f lst)
(let iter ([lst lst])
(if (null? lst)
nil
(let ([head (car lst)]
[tail (cdr lst)])
(f head)
(iter tail)))))
2.27
(define (deep-reverse lst)
(if (pair? lst)
(reverse (map deep-reverse lst))
lst))
2.28
(define (fringe lst)
(if (pair? lst)
(apply append (map fringe lst))
(list lst)))
2.29
(define (left-branch mobile)
(car mobile)) ; define left-branch car
(define (right-branch mobile)
(cadr mobile)) ; define right-branch cadr
(define (total-weight mobile-or-weight)
(if (pair? mobile-or-weight)
(let ([mobile mobile-or-weight])
(let ([lb (left-branch mobile)]
[rb (right-branch mobile)])
(let ([lhs (right-branch lb)]
[rhs (right-branch rb)])
(+ (total-weight lhs)
(total-weight rhs)))))
mobile-or-weight))
(define (balanced? mobile)
(let ([lb (left-branch mobile)]
[rb (right-branch mobile)])
(let ([ll (left-branch lb)]
[lw (total-weight (right-branch lb))]
[rl (left-branch rb)]
[rw (total-weight (right-branch rb))])
(= (* ll lw) (* rl rw)))))
由于在实现的过程中，完全使用接口来使用该结构，所以只需要改变接口对应到新的实现即可，甚至可以不改变 left-branch。
(define left-branch car)
(define right-branch cdr)
2.30
(define (square-tree tree)
(if (pair? tree)
(map square-tree tree)
(square tree)))
(define (square-tree tree)
(let recu ([tree tree])
(cond [(null? tree) nil]
[(pair? tree)
(cons (square-tree (car tree))
(square-tree (cdr tree)))]
[else (square tree)])))
2.31
(define (tree-map f tree)
(let recu ([tree tree])
(cond [(null? tree) nil]
[(pair? tree)
(cons (recu (car tree))
(recu (cdr tree)))]
[else (f tree)])))
2.32
(define (subsets s)
(if (null? s)
(list nil)
(let ([head (car s)]
[rest (subsets (cdr s))])
(append rest
(map (lambda (lst)
(cons head lst))
rest)))))
将 s 的所有子集划分为包含 head 的子集和不包含 head 的子集。
2.33
(define (map p sequence)
(accumulate (lambda (x y) (cons (p x) y)) nil sequence))
(define (append seq1 seq2)
(accumulate cons seq2 seq1))
(define (length sequence)
(accumulate (lambda (_ n) (inc n)) 0 sequence))
2.34
(define (horner-eval x coefficient-sequence)
(accumulate (lambda (this-coeff higher-terms)
(+ this-coeff (* x higher-terms)))
0
coefficient-sequence))
2.35
(define (count-leaves t)
(accumulate + 0 (map (lambda (x)
(if (pair? x)
(count-leaves x)
1))
t)))
2.36
(define (accumulate-n op init seqs)
(if (null? (car seqs))
nil
(cons (accumulate op init (map car seqs))
(accumulate-n op init (map cdr seqs)))))
2.37
(define (dot-product v w)
(accumulate + 0 (map * v w)))
(define (matrix-*-vector m v)
(map (lambda (w) (dot-product v w)) m))
(define (matrix-*-matrix m n)
(let ([cols (transpose n)])
(map (lambda (w) (matrix-*-vector cols w)) m)))
(define (transpose mat)
(accumulate-n cons nil mat))
2.38
(define (fold-right op initial sequence)
(let iter ([reversed-result initial]
[rest sequence])
(if (null? rest)
(reverse reversed-result)
(iter (op (car rest) reversed-result)
(cdr rest)))))
(define (fold-left op initial sequence)
(let iter ([result initial]
[rest sequence])
(if (null? rest)
result
(iter (op result (car rest))
(cdr rest)))))
对比可以看到，如果 op 的两个参数交换，并且将得到的序列（如果结果是序列的话）反转，则结果一样。
如果不想用反转，只需要 fold-right 的 op 每次结合序列时将新元素添加到尾部即可，或者 fold-left 的 op 将新元素添加到尾部，两者选择一种即可。可见下题 2.39。
2.39
(define (reverse sequence)
(fold-right (lambda (x xs) (append xs (list x))) nil sequence))
(define (reverse sequence)
(fold-left (lambda (xs x) (cons x xs)) nil sequence))
2.40
(define (unique-pairs n)
(flatmap (lambda (i)
(map (lambda (j) (list i j))
(enumerate-interval 1 (dec i))))
(enumerate-interval 1 n)))
(define (prime-sum-pairs n)
(map make-pair-sum
(filter prime-sum? (unique-pairs n))))
2.41
(define (sum-equals-to-s-triples n s)
(define (sum-equals-to-r-pairs m r)
(if (or (< r 3)
(< (+ m (dec m)) r))
nil
(map (lambda (k) (list (- r k) k))
(enumerate-interval (max 1 (- r m))
(min m (dec (/ r 2)))))))
(if (or (< s 6)
(< (* 3 (dec n)) s))
nil
(flatmap (lambda (i)
(map (lambda (p) (cons i p))
(sum-equals-to-r-pairs i (- s i))))
(enumerate-interval 1 (min n s)))))
2.42
(define (queens board-size)
(define (safe? k positions)
(let ([kp (car positions)])
(let safe-cols? ([c (dec k)]
[rest (cdr positions)])
(or (= c 0)
(let* ([cp (car rest)]
[ratio (/ (- kp cp)
(- k c))])
(and (not (member ratio '(-1 0 1)))
(safe-cols? (dec c)
(cdr rest))))))))
(define empty-board nil)
(define (adjoin-position new-row k rest-of-queens)
(cons new-row rest-of-queens))
(let queen-cols ([k board-size])
(if (= k 0)
(list empty-board)
(filter (lambda (positions) (safe? k positions))
(flatmap (lambda (rest-of-queens)
(map (lambda (new-row)
(adjoin-position new-row
k
rest-of-queens))
(enumerate-interval 1 board-size)))
(queen-cols (- k 1)))))))
2.43
Louis 的版本内循环为 queen-cols 意味着每次内循环都要计算一次 queen-cols，\(T(k)=kT(k-1)+O(k)\)。
正常的版本每个 k 只需要计算一个 queen-cols。
2.44
(define (up-split painter n)
(if (= n 0)
painter
(let ([smaller (up-split painter (dec n))])
(below painter (beside smaller smaller)))))
2.45
(define ((split larger-painter smaller-painter) painter n)
(let split ([painter painter] [n n])
(if (= n 0)
painter
(let ([smaller (split painter (dec n))])
(larger-painter painter
(smaller-painter smaller smaller))))))
2.46
(define make-vect cons)
(define xcor-vect car)
(define ycor-vect cdr)
(define (add-vect v1 v2)
(make-vect (+ (xcor-vect v1) (xcor-vect v2))
(+ (ycor-vect v1) (ycor-vect v2))))
(define (sub-vect v1 v2)
(add-vect v1 (scale-vect v2 -1)))
(define (scale-vect s v)
(make-vect (* s (xcor-vect v))
(* s (ycor-vect v))))
2.48
(define make-segment cons)
(define start-segment car)
(define end-segment cdr)
2.49
(define ((segments->painter segment-list) frame)
(for-each (lambda (segment)
(draw-line ((frame-coord-map frame)
(start-segment segment))
((frame-coord-map frame)
(end-segment segment))))
segment-list))
(define (outline frame)
(let ([0s (make-vect 0 0)]
[1x (make-vect 1 0)]
[1y (make-vect 0 1)]
[1s (make-vect 1 1)])
(let ([segments (list (make-segment 0s 1x)
(make-segment 1x 1s)
(make-segment 1s 1y)
(make-segment 1y 0s))])
((segments->painter segments) frame))))
(define (draw-x frame)
(let ([0s (make-vect 0 0)]
[1x (make-vect 1 0)]
[1y (make-vect 0 1)]
[1s (make-vect 1 1)])
(let ([segments (list (make-segment 0s 1s)
(make-segment 1x 1y))])
((segments->painter segments) frame))))
(define (draw-◇ frame)
(let ([0.5x (make-vect 0.5 0)]
[0.5y (make-vect 0 0.5)]
[1x+0.5y (make-vect 1 0.5)]
[1y+0.5x (make-vect 0.5 1)])
(let ([segments (list (make-segment 0.5x 1x+0.5y)
(make-segment 1x+0.5y 1y+0.5x)
(make-segment 1y+0.5x 0.5y)
(make-segment 0.5y 0.5x))])
((segments->painter segments) frame))))
2.50
(define (flip-horiz painter)
(transform-painter painter
(make-vect 1.0 0.0)
(make-vect 0.0 0.0)
(make-vect 1.0 1.0)))
(define (rotate180 painter)
(rotate90 (rotate90 painter)))
(define (rotate270 painter)
(rotate90 (rotate180 painter)))
2.51
(define ((below bottom top) frame)
(let ([split-point (make-vect 0.5 0.0)])
(let ([paint-bottom
(transform-painter bottom
split-point
(make-vect 1.0 0.0)
(make-vect 0.5 1.0))]
[paint-top
(transform-painter top
(make-vect 0.0 0.0)
split-point
(make-vect 0.0 1.0))])
(paint-bottom frame)
(paint-top frame))))
(define (below bottom top)
(rotate270 (beside (rotate90 top) (rotate90 bottom))))
2.54
(define (equal? a b)
(if (pair? a)
(and (equal? (car a) (car b))
(equal? (cdr a) (cdr b)))
(eq? a b)))
2.55
''abracadabra -> '(quote abracadabra) -> (list 'quote 'abracadabra)
2.56
(define (exponentiation? x)
(and (pair? x) (eq? (car x) '**)))
(define (base s) (cadr s))
(define (exponent s) (caddr s))
(define (make-exponentiation base exponent)
(cond [(=number? exponent 0) 1]
[(=number? base 0) 0]
[(=number? base 1) 1]
[(and (number? base) (number? exponent))
(expt base exponent)]
[else (list '** base exponent)]))
2.57
(define (augend s)
(let ([rest (cddr s)])
(if (null? rest) 0 (cons '+ rest))))
(define (multiplicand p)
(let ([rest (cddr p)])
(if (null? rest) 1 (cons '* rest))))
2.58
(define (deriv exp var)
(cond [(number? exp) 0]
[(variable? exp) (if (same-variable? exp var) 1 0)]
[(bracketed-exp? exp) (deriv (car exp) var)]
[(sum? exp)
(make-sum (deriv (addend exp) var)
(deriv (augend exp) var))]
[(product? exp)
(make-sum (make-product (multiplier exp)
(deriv (multiplicand exp) var))
(make-product (deriv (multiplier exp) var)
(multiplicand exp)))]
[(exponentiation? exp)
(let ([b (base exp)] [e (exponent exp)])
(make-product (make-product (make-exponentiation b (dec e))
(deriv b var))
e))]
[else (error "unknown expression type: DERIV" exp)]))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (bracketed-exp? exp)
(and (pair? exp) (null? (cdr exp))))
(define (=number? exp num) (and (number? exp) (= exp num)))
(define (opertor-expr? s operator)
(and (pair? s) (memq operator s)))
(define (lhs-operand s operator)
(if (eq? operator (cadr s))
(car s)
(let iter ([s s] [reversed-result nil])
(if (eq? operator (car s))
(reverse reversed-result)
(iter (cdr s) (cons (car s) reversed-result))))))
(define (rhs-operand s operator)
(let ([rhs (cdr (memq operator s))])
(if (bracketed-exp? rhs) (car rhs) rhs)))
(define (sum? s) (opertor-expr? s '+))
(define (addend s) (lhs-operand s '+))
(define (augend s) (cdr (memq '+ s)))
(define (make-sum a1 a2)
(cond [(=number? a1 0) a2]
[(=number? a2 0) a1]
[(and (number? a1) (number? a2)) (+ a1 a2)]
[else (list a1 '+ a2)]))
(define (product? s) (opertor-expr? s '*))
(define (multiplier s) (lhs-operand s '*))
(define (multiplicand s) (cdr (memq '* s)))
(define (make-product m1 m2)
(cond [(or (=number? m1 0) (=number? m2 0)) 0]
[(=number? m1 1) m2]
[(=number? m2 1) m1]
[(and (number? m1) (number? m2)) (* m1 m2)]
[else (list m1 '* m2)]))
(define (exponentiation? s) (opertor-expr? s '**))
(define (base s) (lhs-operand s '**))
(define (exponent s) (rhs-operand s '**))
(define (make-exponentiation base exponent)
(cond [(=number? exponent 0) 1]
[(=number? base 0) 0]
[(=number? base 1) 1]
[(and (number? base) (number? exponent))
(expt base exponent)]
[else (list base '** exponent)]))
2.59
(define (union-set set1 set2)
(cond [(null? set1) set2]
[(null? set2) set1]
[else (union-set (cdr set1)
(adjoin-set (car set1)
set2))]))
2.60
(define (element-of-set? x set)
(cond [(null? set) #f]
[(equal? x (car set)) #t]
[else (element-of-set? x (cdr set))]))
(define (adjoin-set x set) (cons x set))
(define (union-set set1 set2) (append set1 set2))
(define (intersection-set set1 set2)
(if (or (null? set1) (null? set2))
'()
(let ([x (car set1)]
[rest (intersection-set (cdr set1) set2)])
(if (element-of-set? x set2)
(cons x rest)
rest))))
2.61
(define (adjoin-set x set)
(if (null? set)
(list x)
(let ([y (car set)])
(cond [(= x y) set]
[(< x y) (cons x set)]
[else (cons y (adjoin-set x (cdr set)))]))))
2.62
(define (union-set set1 set2)
(cond [(null? set1) set2]
[(null? set2) set1]
[else
(let ([x (car set1)] [xs (cdr set1)]
[y (car set2)] [ys (cdr set2)])
(cond [(> x y) (cons y (union-set set1 ys))]
[(< x y) (cons x (union-set xs set2))]
[else (cons x (union-set xs ys))]))]))
2.63
结果相同，都是将树按序变为列表。tree->list-1 使用的 append 函数，每次合成都要完全新建列表，增加了时空复杂度。
2.64
前 \(\lfloor{n-1\over2}\rfloor\) 构建左子树，再用一个构建根节点，再用 \(n-1-\lfloor{n-1\over2}\rfloor=\lceil{n-1\over2}\rceil\)，构建右子树，剩下的保留。
\(T(n)=T(\lfloor{n-1\over2}\rfloor)+T(\lceil{n-1\over2}\rceil)+O(1)=O(n)\)。
2.65
(define (tree->list tree)
(let recu ([tree tree] [result '()])
(if (null? tree)
result
(recu (left-branch tree)
(cons (entry tree)
(recu (right-branch tree)
result))))))
(define (list->tree elements)
(let partial ([elts elements] [n (length elements)])
(if (= n 0)
(cons '() elts)
(let* ([left-size (quotient (- n 1) 2)]
[left-result (partial elts left-size)])
(let ([left-tree(car left-result)]
[non-left-elts (cdr left-result)]
[right-size (- n left-size 1)])
(let ([this-entry (car non-left-elts)]
[right-result (partial (cdr non-left-elts)
right-size)])
(let ([right-tree (car right-result)]
[remaining-elts (cdr right-result)])
(cons (make-tree this-entry
left-tree
right-tree)
remaining-elts))))))))
(define (union-set set1 set2)
(let ([set1 (tree->list set1)]
[set2 (tree->list set2)])
(list->tree
(let merge ([set1 set1] [set2 set2])
(cond [(null? set1) set2]
[(null? set2) set1]
[else
(let ([x (car set1)]
[y (car set2)]
[xs (cdr set1)]
[ys (cdr set2)])
(cond [(> x y) (cons y (merge set1 ys))]
[(< x y) (cons x (merge xs set2))]
[else (cons x (merge xs ys))]))])))))
(define (intersection-set set1 set2)
(let ([set1 (tree->list set1)]
[set2 (tree->list set2)])
(list->tree
(let intersect ([set1 set1] [set2 set2])
(if (or (null? set1) (null? set2))
'()
(let ([x (car set1)]
[y (car set2)]
[xs (cdr set1)]
[ys (cdr set2)])
(cond [(> x y) (intersect set1 ys)]
[(< x y) (intersect xs set2)]
[else (cons x (intersect xs ys))])))))))
2.66
(define (lookup given-key set-of-records)
(let iter ([set set-of-records])
(if (null? set)
#f
(let ([k (key (entry set-of-records))])
(cond [(< given-key k) (iter (left-branch set))]
[(> given-key k) (iter (right-branch set))]
[else (entry set)])))))
2.68
(define (encode message tree)
(define (encode-symbol symbol)
(or (let recu ([tree tree]
[reversed-result '()])
(cond [(not (leaf? tree))
(or (recu (left-branch tree)
(cons 0 reversed-result))
(recu (right-branch tree)
(cons 1 reversed-result)))]
[(eq? (symbol-leaf tree) symbol)
(reverse reversed-result)]
[else #f]))
(error "symbol is not in the tree:" symbol)))
(if (null? message)
'()
(append (encode-symbol (car message))
(encode (cdr message) tree))))
2.69
(define (generate-huffman-tree pairs)
(define (successive-merge set)
(if (null? (cdr set))
(car set)
(let ([lhs (car set)]
[rhs (cadr set)]
[set (cddr set)])
(let* ([t (make-code-tree lhs rhs)]
[set (adjoin-set t set)])
(successive-merge set)))))
(successive-merge (make-leaf-set pairs)))
2.71
获得的编码接近一条完全由左子树构成的链。
2.72
从 generate-huffman-tree 来看，频数较低的符号在左子树，而 encode 优先搜索左子树，因此两者设计上不够配合。可以将 generate-huffman-tree 或 encode 之一的算法修改一下。此时对于 2.71 的编码，第 \(i\) 个编码需要的时间为 \(O(i)\)，即最短为 \(O(1)\)，最长为 \(O(n)\)。
2.73
理论上 number? variable? 类型是没有操作符的。当然也可以创造一个比较特殊的操作符给它们。不过要重写 operator operands 了。
(define (install-deriv-package)
(define (sum-deriv s var)
(let ([addend (car s)]
[augend (cadr s)])
(make-sum (deriv addend var)
(deriv augend var))))
(define (product-deriv s var)
(let ([multiplier (car s)]
[multiplicand (cadr s)])
(make-sum (make-product (multiplier exp)
(deriv multiplicand var))
(make-product (deriv multiplier var)
(multiplicand exp)))))
(define (exponentiation-deriv s var)
(let ([base (car s)]
[exponent (cadr s)])
(make-product
(make-product (make-exponentiation base
(dec exponent))
(deriv base var))
exponent)))
(define (tag x) (attach-tag 'deriv))
(put 'deriv '+ sum-deriv)
(put 'deriv '* product-deriv)
(put 'deriv '** exponentiation-deriv)
'done)
get 改变的话，put 作相应改变即可。
2.74
(define (get-personnel d)
((get 'personnel d)))
(define (get-record personnel employee-name)
((get 'record `(,(type-tag personnel)))
(content personnel)
employee-name))
(define (get-salary personnel employee-name)
((get 'salary `(,(type-tag personnel)))
(content personnel)
employee-name))
(define (find-employee-record division-list employee-name)
(if (null? division-list)
#f
(or (get-record (get-personnel (car division-list))
employee-name)
(find-employee-record (cdr division-list)
employee-name))))
(define (install-d1-division)
(define (get-personnel)
....)
(define (get-record personnel employee-name)
....)
(define (get-salary personnel employee-name)
(let ([record (get-record personnel employee-name)])
....))
(define (tag x) (attach-tag 'd1 x))
(put 'personnel 'd1
(lambda () (tag (get-personnel-d1))))
(put 'record '(d1)
(lambda () (tag get-record)))
(put 'salary '(d1) get-salary-d1)
'done)
因为每个部门的文件 personnel 和部门下每个职员的记录格式 record 因部门不同而不同，需要做标记。
2.75
(define (make-from-mag-ang m a)
(define (dispatch op)
(case op
[(magnitude) m]
[(angle) a]
[(real-part) (* m (cos a))]
[(imag-part) (* m (sin a))]
[else (error "Unknown op: MAKE-FROM-MAG-ANG" op)]))
dispatch)
2.77
; in user package
(magnitude z)
(apply (get 'magnitude '(complex)) '(,(content z)))
; in complex package
(magnitude (content z))
(apply (get 'polar '(polar)) '(,(content (content z))))
; in polar package, for instance
(magnitude (content (content z)))
2.78
(define (scheme-internal-type? datum)
(or (symbol? datum)
(number? datum)
(string? datum)
(....)))
(define (type-tag datum)
(cond [(symbol? datum) 'scheme-symbol]
[(number? datum) 'scheme-number]
[(string? datum) 'scheme-string]
[....]
[else (car datum)]))
(define (content datum)
(if (scheme-internal-type? datum) datum (cdr datum)))
(define (attach-tag type-tag contents)
(if (scheme-internal-type? datum) datum (cdr datum)))
2.79
(define (equ? a b)
(apply-generic 'equ a b))
; scheme-number-package
(put 'equ '(scheme-number scheme-number) =)
; rational-package
(put 'equ '(rational rational)
(lambda (a b) (= (numer (sub-rat x y)) 0)))
; complex-packge
(put 'equ '(complex complex)
(lambda (a b)
(let ([diff (sub-complex a b)])
(= (real-part diff) (imag-part diff) 0))))
2.80
(define (=zero? n)
(apply-generic '=zero? n))
; scheme-number-package
(put '=zero? '(scheme-number)
(lambda (n) (= n 0)))
; rational-package
(put '=zero? '(rational)
(lambda (n) (= (numer n) 0)))
; complex-packge
(put '=zero? '(complex)
(lambda (n) (= (real-part n) (imag-part n) 0)))
2.81
exp 函数正常工作，但不需要添加本类型的转换，当真的不存在接受两个同类型参数的函数时，会无限循环。
(define (apply-generic op . args)
(let* ([type-tags (map type-tag args)]
[proc (get op type-tags)])
(cond [proc (apply proc (map contents args))]
[(= (length args) 2)
(let ([t1 (car type-tags)]
[t2 (cadr type-tags)])
(if (eq? t1 t2)
(error "No method for these types"
(list op type-tags))
(let ([t1->t2 (get-coercion t1 t2)]
[t2->t1 (get-coercion t2 t1)]
[a1 (car args)]
[a2 (cadr args)])
(cond [t1->t2
(apply-generic op (t1->t2 a1) a2)]
[t2->t1
(apply-generic op a1 (t2->t1 a2))]
[else
(error "No method for these types"
(list op type-tags))]))))]
[else (error "No method for these types"
(list op type-tags))])))
2.82
(define (apply-generic op . args)
(define (try-coercion arg type)
(let ([t (type-tag arg)]
[c (get-coercion t type)])
(cond [(eq? type t) arg]
[c (c arg)]
[else #f])))
(let* ([type-tags (map type-tag args)]
[proc (get op type-tags)])
(if proc
(apply proc (map contents args))
(let try-type ([types type-tags])
(if (null? types)
(error "No method for these types"
(list op type-tags))
(let* ([t (car types)]
[c (get op (map (lambda (_) t) args))])
(if c
(apply c (map (lambda (a)
(contents (try-coercion a t)))
args))
(try-type (cdr types)))))))))
2.83
(define (raise datum)
(let ([raiser (get 'raise (type-tag datum))])
(if raise (raise datum) #f)))
; scheme-number-package
(put 'raise 'scheme-number
(lambda (x) (make-rational (contents x) 1)))
; rational-package
(put 'raise 'rational
(lambda (n) (make-from-real-imag (contents n) 0)))
2.84
(define (apply-generic op . args)
(define (no-methods)
(error "No method for these types"
(list op (map type-tag args))))
(define (try-raise-to datum type)
(let iter ([datum datum])
(and datum
(if (eq? type (type-tag datum))
datum
(iter (raise datum))))))
(let* ([type-tags (map type-tag args)]
[proc (get op type-tags)])
(cond [proc (apply proc (map contents args))]
[(= (length args) 2)
(let ([a1 (car args)]
[a2 (cadr args)]
[t1 (car type-tags)]
[t2 (cadr type-tags)])
(if (eq? t1 t2)
(no-methods)
(let ([ra1 (try-raise-to a1 t2)]
[ra2 (try-raise-to a2 t1)])
(cond [ra1 (apply-generic op ra1 a2)]
[ra2 (apply-generic op a1 ra2)]
[else (no-methods)]))))]
[else (no-methods)])))
2.85
(define (project datum)
(let ([p (get 'project (type-tag datum))])
(if p (p datum) #f)))
; rational-package
(put 'project 'rational
(lambda (n)
(make-scheme-number (quotient (numer n)
(denom n)))))
; complex-package
(put 'project 'complex
(lambda (x)
(make-rational (real-part x))))
(define (drop datum)
(let ([projected (project datum)])
(if (eq? datum (raise projected))
(drop projected)
datum)))
Modularity, Objects, and State
两种组织策略：objects 和 streams。
set! 的加入使求值方式发生了改变；可变变量不仅代表一个值，还代表了一个地址。
每个变量都代表一个序偶，分别包含变量的值和变量所在环境的指针。应用函数时会创造属于这个函数的环境，注意分清函数所在的环境和属于函数的环境。
imperative-style expression-oriented style
并发操作和锁
惰性求值和流
流在 Python 中感觉就像
def integers():
yield 0
for i in integers():
yield i + 1
Exercise
3.1
(define ((make-accumulator n) c)
(begin (set! n (+ c n))
n))
3.2
(define (make-monitored f)
(let ([count 0])
(lambda (input)
(case input
[(how-many-calls?) count]
[(reset-count) (set! count 0)]
[else (begin (set! count (inc count))
(f input))]))))
3.3
(define ((make-account balance password)
input-password m)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(define (dispatch m)
(cond [(eq? m 'withdraw) withdraw]
[(eq? m 'deposit) deposit]
[else (error "Unknown request: MAKE-ACCOUNT"
m)]))
(if (eq? password input-password)
(dispatch m)
(error "Incorrect password")))
3.4
(define (make-account balance password)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(define (dispatch m)
(cond [(eq? m 'withdraw) withdraw]
[(eq? m 'deposit) deposit]
[else (error "Unknown request: MAKE-ACCOUNT"
m)]))
(define (call-the-cops)
(error "call the cops"))
(let ([incorrect-count 0])
(lambda (input-password m)
(if (eq? password input-password)
(dispatch m)
(begin (set! incorrect-count
(inc incorrect-count))
(if (>= incorrect-count 7)
(call-the-cops)
(error "Incorrect password")))))))
3.5
(define (estimate-integral p x1 x2 y1 y2 trials)
(let ([x1 (exact->inexact x1)]
[x2 (exact->inexact x2)]
[y1 (exact->inexact y1)]
[y2 (exact->inexact y2)])
(monte-carlo trials
(lambda ()
(p (random-in-range x1 x2)
(random-in-range y1 y2))))))
(define (estimate-pi-by-integral trials)
(* 4.
(estimate-integral (lambda (x y)
(> 1 (+ (expt x 2)
(expt y 2))))
-1 1 -1 1
trials)))
3.6
(define rand
(let ([x (random 4294967087)])
(lambda (action)
(case action
[(generate) (let ([new-x (remainder (+ (* 1103515245 x)
12345)
4294967087)])
(set! x new-x)
x)]
[(reset) (lambda (new-x) (set! x new-x))]
[else (error "unknown argument")]))))
3.7
(define (make-joint account password new-password)
(define (test)
((account password 'withdraw) 0))
(test)
(let ([alias-password new-password])
(lambda (input-password m)
(if (eq? alias-password input-password)
(account password m)
(error "incorrect password")))))
; equivalently, without let
(define (make-joint account password new-password)
(define (test)
((account password 'withdraw) 0))
(test)
(lambda (input-password m)
(if (eq? new-password input-password)
(account password m)
(error "incorrect password"))))
3.8
(define f
(let ([x #f])
(lambda (n)
(or x (begin (set! x n)
x)))))
3.9
两个函数创造的环境的过程是相同的，使用了尾递归的函数可以在新的环境被创建的时候回收旧的环境，或者直接改变旧的环境为新的环境。
3.10
(define (make-withdraw balance)
(lambda (amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds")))
; let version
(define (make-withdraw initial-amount)
(let ([balance initial-amount])
(lambda (amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))))
; let in lambda form
(define (make-withdraw initial-amount)
((lambda (balance)
(lambda (amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds")))
initial-amount))
let 版本的函数增加了一层容纳 initial-amount 的环境。
3.13
无限循环。
3.14
效果相当于 reverse。
3.17
(define (count-pairs x)
(length
(let recu ([x x]
[record '()])
(if (not (pair? x))
record
(let ([record (if (memq x record)
record
(cons x record))])
(recu (cdr x)
(recu (car x)
record)))))))
3.18 3.19
快慢指针检测链表中是否有环
(define (detect-cycle lst)
(if (or (not (pair? lst))
(null? (cdr lst))
(null? (cddr lst)))
#f
(let* ([slow (cdr lst)]
[fast (cdr slow)])
(let iter ([slow slow]
[fast fast])
(cond [(eq? fast slow) fast]
[(or (null? (cdr fast))
(null? (cddr fast)))
#f]
[else (iter (cdr slow)
(cddr fast))])))))
3.21
delete-queue! 不会改变 rear-ptr 的状态，而 empty-queue? 也不检测 rear-ptr。
(define (print-queue q)
(display (front-ptr q)))
3.22
以非循环单链表实现
(define (make-queue)
(let* ([head-ptr (cons '() '())] ; can't be replaced with '(())
[rear-ptr head-ptr])
(define (empty?)
(eq? head-ptr rear-ptr))
(define (insert! item)
(set-cdr! rear-ptr (cons item '()))
(set! rear-ptr (cdr rear-ptr)))
(define (front)
(if (empty?)
(error "empty queue")
(cadr head-ptr)))
(define (delete!)
(cond [(empty?) (error "empty queue")]
[(null? (cddr head-ptr))
(begin (set! head-ptr (cons '() '()))
(set! rear-ptr head-ptr))]
[else (set-cdr! head-ptr (cddr head-ptr))]))
(define (print)
(display (cdr head-ptr)))
(define (dispatch m)
(case m
[(empty-queue?) (empty?)]
[(insert-queue!) insert!]
[(front-queue) (front)]
[(delete-queue!) (delete!)]
[(print) (print)]
[else (error "unknown argument" m)]))
dispatch))
(define (empty-queue? q)
(q 'empty-queue?))
(define (insert-queue! q item)
((q 'insert-queue!) item)
q)
(define (delete-queue! q)
(q 'delete-queue!)
q)
(define (front-queue q)
(q 'front-queue))
(define (print-queue q)
(q 'print))
3.23
以非循环双链表实现
(define (make-deque)
(define (make-node v p n)
(cons v (cons p n)))
(define (set-prev! ptr prev)
(set-car! (cdr ptr) prev))
(define (set-next! ptr next)
(set-cdr! (cdr ptr) next))
(define (prev ptr) (cadr ptr))
(define (next ptr) (cddr ptr))
(define (value ptr) (car ptr))
(define (connect p q)
(set-next! p q)
(set-prev! q p))
(define (disconnect p q)
(if (or (null? p) (null? q))
#f
(begin (set-next! p '())
(set-prev! q '())
#t)))
(let* ([front-ptr '()]
[rear-ptr '()])
(define (init node)
(set! front-ptr node)
(set! rear-ptr node))
(define (empty?)
(or (null? front-ptr)
(null? rear-ptr)))
(define (insert-front! item)
(let ([node (make-node item '() '())])
(if (empty?)
(init node)
(begin (connect node front-ptr)
(set! front-ptr node)))))
(define (delete-front!)
(if (empty?)
(error "empty deque")
(let ([next-ptr (next front-ptr)])
(disconnect front-ptr next-ptr)
(set! front-ptr next-ptr))))
(define (front)
(if (empty?)
(error "empty deque")
(value front-ptr)))
(define (insert-rear! item)
(let ([node (make-node item '() '())])
(if (empty?)
(init node)
(begin (connect rear-ptr node)
(set! rear-ptr node)))))
(define (delete-rear!)
(if (empty?)
(error "empty deque")
(let ([prev-ptr (prev front-ptr)])
(disconnect prev-ptr rear-ptr)
(set! rear-ptr prev-ptr))))
(define (rear)
(if (empty?)
(error "empty deque")
(value rear-ptr)))
(define (print)
(display (if (empty?)
'()
(let iter ([ptr rear-ptr]
[result '()])
(if (null? ptr)
result
(iter (prev ptr)
(cons (value ptr)
result)))))))
(define (dispatch m)
(case m
[(empty?) (empty?)]
[(insert-front!) insert-front!]
[(delete-front!) (delete-front!)]
[(front) (front)]
[(insert-rear!) insert-rear!]
[(delete-rear!) (delete-rear!)]
[(rear) (rear)]
[(print) (print)]
[else (error "unknown method" m)]))
dispatch))
3.24
使用 assoc 作为查询函数，只需要修改 assoc 中的 equal? 为 make-table 时传入的函数即可。
3.25
(define (lookup keys table)
(if (null? keys)
(error "empty keys")
(let iter ([keys keys]
[table table])
(let ([key (car keys)]
[keys (cdr keys)])
(let ([subtable (assoc key (cdr table))])
(cond [(not subtable) #f]
[(null? keys) (cdr subtable)]
[else (iter keys (cdr subtable))]))))))
(define (insert! keys value table)
(if (null? keys)
(error "empty keys")
(let iter ([keys keys]
[table table])
(let ([key (car keys)]
[keys (cdr keys)])
(let ([subtable (assoc key (cdr table))])
(if subtable
(if (null? keys)
(set-cdr! subtable value)
(iter keys subtable))
(if (null? keys)
(set-cdr! table
(cons (cons key value)
(cdr table)))
(begin (set-cdr! table
(cons (list key)
(cdr table)))
(iter keys (cadr table))))))))))
3.26
可以参考 2.65 2.66 的二叉树实现，无非是将树的节点由单纯的值变为键值对。
3.27
(define (fib n)
(case n
[(0) 0]
[(1) 1]
[else (+ (fib (- n 1))
(fib (- n 2)))]))
这种方式实现的 Fibonacci 数列时空复杂度约为指数，因为 (fib (-n 1)) 和 (fib (- n 2)) 之间有着大量的重复计算。采用记录的方法可以降低时空复杂度。我们还将发现如果使用链表作为记录的实现载体，由于插入时采用在头节点插入的方式，链表的组织是自然有序的。因此查询的开销接近常数，也就是 \(O(1)\)。此时时空复杂度都为 \(O(n)\)。
(memoize f) 实际上创建了一个新函数，这个新函数有着属于它的一个记录。但如果使用 (memoize fib)，fib 本身在函数体中使用的是 fib 进行递归，没有查询的操作，等于浪费了这个记录，不能降低时空复杂度。
3.28
(define (or-gate a1 a2 output)
(define (or-action-procedure)
(let ([new-value
(logical-or (get-signal a1) (get-signal a2))])
(after-dalay
or-gate-delay
(lambda () (set-signal! output new-value)))))
(add-action! a1 or-action-procedure)
(add-action! a2 or-action-procedure)
'ok)
3.29
; (or a b) == (not (and (not a) (not b)))
(define (or-gate-by-and-not a1 a2 output)
(let ([na (make-wire)]
[nb (make-wire)]
[no (make-wire)])
(inverter a na)
(inverter b nb)
(and-gate na nb e)
(inverter no output)))
如果 ab 取反可以并行，则延迟为 3 inverter-dalay + 1 and-gate-dalay。
3.30
(define (ripple-carry-adder k ak bk c-in sk c-out)
((let ([k (- k 1)]
[a (car ak)]
[ak (cdr ak)]
[b (car bk)]
[bk (cdr bk)]
[s (car sk)]
[sk (cdr sk)])
(if (= k 1)
(full-adder a b c-in s c-out)
(let ([c (make-wire)])
(full-adder a b c-in s c)
(ripple-carray-adder k ak bk c sk c-out))))))
\(D_\text{ripple-carry-adder}(k)=\begin{cases}\text{full-adder-delay}&k=1\\\text{full-adder-delay}+D(k-1)&k>1\end{cases}=k\times\text{full-adder-delay}\)
3.31
不妨使用 inverter 的动作作为演示
(add-action! input invert-input)
(accept-action-procedure! invert-input)
(set! action-procedures
(cons invert-input action-procedures))
(invert-input))
(set! action-procedures
(cons invert-input action-procedures))
(after-delay inverter-delay
(lambda () (set-signal! output new-value))))
(set! action-procedures
(cons invert-input action-procedures))
(add-to-agenda! (+ inverter-delay (current-time the-agenda))
(lambda () (set-signal! output new-value))
the-agenda))
(proc) 的功能是将函数添加到 agenda 的动作序列中。
而在执行时，会在对应时刻执行相应动作。
(propagate)
(first-item)
(set-current-time! agenda
(segment-time first-seg))
((front-queue (segment-queue first-seg)))
这些动作必然会通过 set-signal! 导致某个 wire 状态的改变，这个动作又会添加新的动作到 agenda 的动作序列中。上述动作不断进行，直到到达平衡状态。
最终结论是，(proc) 先将所有组件进行初始化，并将相应动作添加到 agenda 的动作序列中。
3.32
先添加的动作会被先执行。使用 set-signal! 会使新的动作被添加，如果后添加的动作先执行，那么新的动作就变成新添加的了，又会导致新的动作被后执行。如此反复，所有动作及其延申结果都会在执行顺序的先后上震荡。
注意 and-action-procedure 是先将结果保存起来，在延时后改变与门结果。对 and-gate 输入 0,1，与门的结果为 0。如果先改变 0 为 1，再改变 1 为 0：
- FIFO 队列，
0->1引发与门的结果的改变为1，1->0引发与门结果的改变为0。到了与门的执行时刻，那么与门的结果为0->1->0。 - LIFO 栈，
0->1引发与门的结果的改变为1，1->0引发与门结果的改变为0。到了与门的执行时刻，那么与门的结果为0->0->1，出错。
3.33
(define (averager a b c)
(define (process-new-value)
(cond [(and (has-value? a)
(has-value? b))
(set-value! c
(/ (+ (get-value a)
(get-value b))
2)
me)]
[(and (has-value? a)
(has-value? c))
(set-value! b
(- (* 2 (get-value c))
(get-value a))
me)]
[(and (has-value? b)
(has-value? c))
(set-value! a
(- (* 2 (get-value c))
(get-value b))
me)]))
(define (process-forget-value)
(forget-value! c me)
(forget-value! a me)
(forget-value! b me)
(process-new-value))
(define (me request)
(case request
[(I-have-a-value) (process-new-value)]
[(I-lost-my-value) (process-forget-value)]
[else (error "Unknown request: AVERAGER"
request)]))
(connect a me)
(connect b me)
(connect c me)
me)
3.34
可以从 a 推出 b，但是无法从 b 推出 a。
3.35
(define (squarer a b)
(define (process-new-value)
(if (has-value? b)
(if (< (get-value b) 0)
(error "square less than 0: SQUARER"
(get-value b))
(set-value! a
(sqrt (get-value b))
me))
(if (has-value? a)
(set-value! b
(square (get-value a))
me))))
(define (process-forget-value)
(forget-value! a me)
(forget-value! b me)
(process-new-value))
(define (me request)
(case request
[(I-have-a-value) (process-new-value)]
[(I-lost-my-value) (process-forget-value)]
[else (error "Unknown request: SQUARER"
request)]))
(connect a me)
(connect b me)
me)
3.36
一个 connector 对应多个 constraint，一个 constraint 包含多个 connector。
对于 connector，它所对应的 constraint 中有一个特殊的 informant，相当于只有这个 informant 可以写入 connector，其他 constraint 只能读取。
当 connector 写入时，通过 connector 和 constraint 的对应关系在等式中传播，没有值的 connector 被写入并获得 informant。
当 connector 取消值时，通过 connector 和 constraint 的对应关系在等式中传播，constraint 正好为 informant 的 connector 的值也被取消。
connector 的环境中包含它所对应的 constraint，被传入 for-each-except。在这里，每个 constraint 被解析，其实是每个组件（比如 adder）中的一个函数，组件也包含它的环境，是两个 process 函数和 me 函数。实际上是在 connector 和 constraint 的环境不断跳跃的过程。
3.37
(define (c+ x y)
(let ([z (make-connector)])
(adder x y z)
z))
(define (c* x y)
(let ([z (make-connector)])
(multiplier x y z)
z))
(define (c/ z x)
(let ([y (make-connector)])
(multiplier x y z)
y))
(define (cv v)
(let ([c (make-connector)])
(constant v c)
c))
3.39
三个操作：p1 的读算、p1 的写、p2。
121
100
101
3.40
p1 分为读第一个 x，读第二个 x，乘法，写 x，四步；
p2 分为读第一个 x，读第二个 x，乘法，读第三个 x，乘法，写 x，六步。
加上 s 后，p1,p2 变为原子操作。
3.41
balance 是一个原子操作。
将读取加入 serializer 中阻止了 withdraw, deposit, balance 三者任意的并行，但是 withdraw, deposit 两者只有在最后一步写操作中才会修改 x 的值。读取操作要么获得写之前的 x，要么获得写之后的 x，但是两种结果都是可取的。因为写之前的 x 可以当作 withdraw, deposit 整个操作之前的 x，而写之后的 x 则是 withdraw, deposit 整个操作之后的 x。
3.42
同一个账户的 withdraw, deposit 操作不能并行。
Ben 的版本的不同之处在于每次调用 (protected action) 生成的序列操作到底能否合成为同一个。
不妨考虑使用 parallel-execute 尝试并行一些操作吧。
(parallel-execute (protect action)
(protect action))
(parallel-execute protected-action
protected-action)
这其中的差别是：受到同一个序列器 protect 序列化后的 action，两个 (protect action) 实际上是不同的实例，意味着 action 和 action 不会交错运行；而 protected-action 是一个实例。
protect 的操作会阻止其他具有相同 serializer 对象的并行；但 protected-action 是相同的实例，不会阻止并行，可能导致错误。
3.44
exchange 中先从两个账户中获得余额，计算差额，分别对两个账户取和存。因此即使两个账户的 withdraw, deposit 都是经过序列器保护的。但整个 exchange 操作仍然是不安全的，因为在计算差额的前后都可能会加入其他并行操作。
但 transfer 只有两个账户的取和存，如果有其他并行操作，只会加到取和存两个操作中间，这并不会影响两个账户的余额发生错误。
3.45
serialized-exchange 实际上是将整个 exchange 操作序列化。而 Louis 的版本在其中又添加了 withdraw 和 deposit 的序列化操作。由于同一时间只能有一个序列化操作，程序将卡死。
3.46
A 执行 test-and-set! 时进行到 begin 中时，被 B 打断，此时执行 B。显然 A 和 B 所代表的程序都执行成功，和 account 时候的情况就类似了。
3.47
(define (make-semaphore n)
(let ([mutex (make-mutex)]
[x n])
(define (acquire)
(mutex 'acquire)
(if (> x 0)
(begin (set! x (- x 1))
(mutex 'release))
(begin (mutex 'release)
(acquire))))
(define (release)
(mutex 'acquire)
(if (< x n)
(set! x (+ x 1)))
(mutex 'release))
(define (dispatch m)
(case m
[(acquire) (acquire)]
[(release) (release)]))
dispatch))
(define (test-and-set! cell)
(let ([x (car cell)])
(if (= x 0)
#t
(begin (set-car! cell (- x 1))
#f))))
(define (clear! cell)
(set-car! cell (+ 1 (car cell))))
(define (make-semaphore n)
(let ([cell (list n)])
(define (the-semaphore m)
(case m
[(acquire)
(if (test-and-set! cell)
(the-semaphore 'acquire))]
[(release)
(if (< (car cell) n)
(clear! cell))]))
the-semaphore))
3.48
(define make-account-and-serializer-with-id
(let ([max-id 0])
(define (make-account-and-serializer balance id)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(let ([balance-serializer (make-serializer)])
(define (dispatch m)
(cond [(eq? m 'withdraw) withdraw]
[(eq? m 'deposit) deposit]
[(eq? m 'balance) balance]
[(eq? m 'serializer) balance-serializer]
[(eq? m 'id) id]
[else (error "Unknown request: MAKE-ACCOUNT" m)]))
dispatch))
(lambda (balance)
(set! max-id (+ max-id 1))
(make-account-and-serializer balance max-id))))
(define (serialized-exchange account1 account2)
(let ([id1 (account1 'id)]
[id2 (account2 'id)]
[serializer1 (account1 'serializer)]
[serializer2 (account2 'serializer)])
(cond [(< id1 id2)
((serializer2 (serializer1 exchange))
account1
account2)]
[(> id1 id2)
((serializer1 (serializer2 exchange))
account1
account2)])))
实际上 id 的取值还可以更复杂一些，但这里只是简单地递增每个新账户的 id。
3.50
(define (stream-map proc . argstreams)
(if (stream-null? (car argstreams))
the-empty-stream
(cons-stream
(apply proc (map stream-car argstreams))
(apply stream-map
(cons proc (map stream-cdr
argstreams))))))
3.54
(define (mul-streams s1 s2)
(stream-map * s1 s2))
(define factorials
(cons-stream 1 (mul-streams (stream-cdr integers)
factorials)))
3.55
(define (partial-sums stream)
(let ([x (stream-car stream)]
[xs (stream-cdr stream)])
(cons-stream x (add-streams (scale-stream ones x)
(partial-sums xs)))))
3.56
(define (map-if predicate proc sequence)
(if (null? sequence)
'()
(let ([x (car sequence)]
[xs (cdr sequence)])
(cons (if (predicate x) (proc x) x)
(map-if predicate proc xs)))))
(define (merge . streams)
(if (null? (filter stream-null? streams))
(let* ([scar (map stream-car streams)]
[min-car (apply min scar)])
(cons-stream min-car
(apply merge
(map-if (lambda (s)
(= min-car
(stream-car s)))
stream-cdr
streams))))
(apply merge
(filter (lambda (s)
(not (stream-null? s)))
streams))))
(define S
(cons-stream 1 (apply merge
(map (lambda (i)
(scale-stream S i))
'(2 3 5)))))
3.57
对 (stream-ref fibs n) 展开
(define fibs
(cons-stream
0
(cons-stream 1 (add-streams (stream-cdr fibs) fibs))))
(stream-ref fibs n)
(stream-ref (cons-stream 1
(add-streams (stream-cdr fibs)
fibs))
(- n 1))
(stream-ref (add-streams (stream-cdr fibs)
fibs)
(- n 2))
(stream-ref (stream-map +
(stream-cdr fibs)
fibs)
(- n 2))
(stream-ref (stream-map +
(stream-cddr fibs)
(stream-cdr fibs))
(- n 3))
(stream-ref (stream-map +
(stream-cdddr fibs)
(stream-cddr fibs))
(- n 4))
(stream-ref (stream-map +
(stream-cn-1dr fibs)
(stream-cn-2dr fibs))
(- n n))
(+ (stream-ref fibs (- n 1))
(stream-ref fibs (- n 2)))
(stream-ref .... n) 的时间复杂度为指数。
3.58
(/ (* num radix) den) 的整数和小数部分
(exact->inexact (/ (* num radix)
den))
3.59
(define (integrate-series stream)
(define harmonic-seq
(stream-map / ones integers))
(mul-streams harmonic-seq stream))
\[\begin{align*}
(e^x)^\prime&=e^x\\
\cos^{\prime\prime}x&=-\cos x\\
\sin^{\prime\prime}x&=-\sin x
\end{align*}
\]
(define cosine-series
(cons-stream
1
(integrate-series
(cons-stream
0
(integrate-series
(stream-map - cosine-series))))))
(define sine-series
(cons-stream
0
(integrate-series
(cons-stream
1
(integrate-series
(stream-map - sine-series))))))
或者交叉地
(define cosine-series
(cons-stream 1
(integrate-series
(stream-map - sine-series))))
(define sine-series
(cons-stream 0
(integrate-series cosine-series)))
3.60
\[\begin{align*}
\sum_{k=0}^\infty a_kx^k\cdot\sum_{b=0}^\infty b_kx^k&=a_kb_k\\&+a_0x\sum_{k=0}^\infty b_{k+1}x^k\\
&+b_0x\sum_{k=0}^\infty a_{k+1}x^k\\
&+x^2\sum_{k=0}^\infty a_{k+1}x^k\cdot\sum_{k=0}^\infty b_{k+1}x^k
\end{align*}
\]
(define (mul-series s1 s2)
(let ([c1 (stream-car s1)]
[c2 (stream-car s2)])
(cons-stream
(* c1 c2)
(add-streams
(add-streams (scale-stream (stream-cdr s1) c2)
(scale-stream (stream-cdr s2) c1))
(cons-stream 0
(mul-series (stream-cdr s1)
(stream-cdr s2)))))))
注意不能在 let 中计算 stream-cdr 的结果，要放在 cons-stream 中等到后面使用的时候再计算。否则，递归地使用 mul-series 可能爆栈。
比如
; another version of mul-series
(define (mul-series s1 s2)
(let ([c1 (stream-car s1)]
[c2 (stream-car s2)]
[cs1 (stream-cdr s1)]
[cs2 (stream-cdr s2)])
(cons-stream
(* c1 c2)
(add-streams
(add-streams (scale-stream cs1 c2)
(scale-stream cs2 c1))
(cons-stream 0
(mul-series cs1 cs2))))))
(define (foo stream)
(cons-stream (stream-car stream)
(mul-series stream
(foo stream))))
(foo ones) ; 1 1 2 4 8 16 32 64 ...
(stream-ref (foo ones) 10) ; stack overflow
3.61
(define (invert-unit-series stream)
(define (invert-unit-series-handler cs)
(define result
(cons-stream 1 (stream-map - (mul-series cs
result))))
result)
(let ([c (stream-car stream)]
[cs (stream-cdr stream)])
(if (not (= c 1))
(error "constant term should be 1" c)
(invert-unit-series-handler cs))))
3.62
(define (div-series s1 s2)
(let ([c (stream-car s2)])
(if (= c 0)
(error "denominator series begins with 0")
(mul-series s1
(scale-stream (invert-unit-series
(scale-stream s2 (/ c)))
(/ c))))))
3.63
依旧是展开
(define (sqrt-stream x)
(define guesses
(cons-stream 1.0
(stream-map (lambda (guess)
(sqrt-improve guess x))
guesses)))
guesses)
(stream-ref (sqrt-stream x) n)
(stream-ref (stream-map (lambda (guess)
(sqrt-improve guess x))
guesses)
(- n 1))
(stream-ref (stream-map (lambda (guess)
(sqrt-improve guess x))
(stream-cdr guesses))
(- n 2))
stream-ref 每前进一步，都需要再遍历一次 guesses。但对于是否有使用 memo-proc 优化。情况会不一样，区别在于 stream-cdr 是否要重新计算一次 guess。继续展开
(stream-ref (stream-map (lambda (guess)
(sqrt-improve guess x))
(stream-cdr guesses))
(- n 2))
; memorized guesses = (1.0 1.5 . #<promise>)
; non-memorized guesses = (1.0 . #<promise>)
可能在示意中不同明显，看上去只是一个 1.5 的差别，但是 memorized guesses 是可以增长的。而 non-memorized guesses 每次都会是一个全新的量，在递归地情况下，每次递归都要完全重新计算一遍。也就是说计算 non-memorized guesses 的第 n 个值，要将长度分别为 1, 2, 3, ..., n-1, n 的 non-memorized guesses 都重新计算一遍。相反，memorized guesses 只需要将新的值添加到流中。
如果没用 memo-proc 处理，那么是相同的。
3.64
(define (stream-limit stream tolerance)
(let ([x (stream-car stream)]
[xs (stream-cdr stream)])
(let ([y (stream-car xs)])
(if (> tolerance
(abs (- y x)))
y
(stream-limit xs tolerance)))))
3.65
; ln2 = 0.6931471805599453...
(define (ln2-summands n)
(cons-stream (/ 1.0 n)
(stream-map - (ln2-summands (+ n 1)))))
(define ln2-stream
(partial-sums (ln2-summands 1)))
(euler-transform ln2-stream)
(accelerated-sequence euler-transform ln2-stream)
\[\begin{align*}
S_{n-1}&=S\\
S_n&=S_{n-1}+a\\
S_{n+1}&=S_n+b\\
S_{n+1}-{(S_{n+1}-S_n)^2\over S_{n-1}-2S_n+S_{n+1}}&=S+a+b-{b^2\over b-a}\\
&=S+{a^2\over a-b}
\end{align*}
\]
因为 \(S\) 收敛，故 \(a,b\) 也收敛。不妨取 \(b<0<a\)，\(a^2\over a-b\) 可以看作 \(a,b\) 按比例收缩或放大 \(a^2\)，若 \(a=-b\)，则 \({a^2\over a-b}=a/2\)。
3.66
\[\begin{align*}
\begin{array}{c|ccc}
(S_0,T_0)&(S_0,T_1)&(S_0,T_2)&\ldots\\\hline
&(S_1,T_1)&(S_1,T_2)&\ldots\\
&&(S_2,T_2)&\ldots\\
&&&\ldots
\end{array}
\end{align*}
\]
pairs 生成的流，分为三个部分，这三部分的索引分别为 0、奇数、偶数。
对于 (pairs integers integers) 生成的流，在以 \((k,k)\) 开头的流中寻找 \((i,j)\) 的位置的算法为
\[\begin{align*}
pos(i,j;k)&=\begin{cases}
0&i=j=k\\
2(j-i)-1&i=k<j\\
2pos(i,j;k+1)+2&i,j>k
\end{cases}
\end{align*}
\]
\(pos\) 是以 \((i,j)\) 决定初值，以 \(k\) 为底的数列。递推公式为 \(pos_k=2pos_{k+1}+2\)，解特征方程 \(1-3x+2x^2=0\)，得 \(x=1,1/2\)，\(pos_k=a+b(1/2)^k\)。
代入初值得
\[\begin{align*}
pos(i,j;k)&=\begin{cases}
-2+2^{i-k+1}&i=j\\
-2+[2(j-i)+1]\cdot2^{i-k}&i<j
\end{cases}\\
pos(i,j;1)&=\begin{cases}
-2+2^i&i=j\\
-2+[2(j-i)+1]\cdot2^{i-1}&i<j
\end{cases}
\end{align*}
\]
可以看到，对于 \(i\) 是指数增长的，对于 \(j\) 是线性增长的。
(define (pos i j)
(if (= i j)
(- (expt 2 i) 2)
(- (* (+ 1 (* 2 (- j i)))
(expt 2 (- i 1)))
2)))
3.67
\[\begin{align*}
\begin{array}{c|ccc}
(S_0,T_0)&(S_0,T_1)&(S_0,T_2)&\ldots\\\hline
(S_1,T_0)&(S_1,T_1)&(S_1,T_2)&\ldots\\
(S_2,T_0)&(S_2,T_1)&(S_2,T_2)&\ldots\\
(S_3,T_0)&(S_3,T_1)&(S_3,T_2)&\ldots
\end{array}
\end{align*}
\]
增加了左侧和左下侧的流。
(define (pairs s t)
(cons-stream
(list (stream-car s) (stream-car t))
(interleave
(stream-map (lambda (x) (list x (stream-car t)))
(stream-cdr s))
(interleave
(stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(pairs (stream-cdr s) (stream-cdr t))))))
3.68
显然会栈溢出，interleave 是一个函数，要求它的参数在使用前被计算为值，尝试计算 (pairs (stream-cdr s) (stream-cdr t)) 导致无限递归，最终溢出。
3.69
现已知 (triples s t u) 得到的 \((S_i,T_j,U_k)\) 满足 \(i\le j\le k\)。只需要求出 (triples s t u) 与 (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)) 的差集，然后用 interleave 组合即可。
我们知道 (stream-ref (stream-cdr s) i) 等同于 (stream-ref s (+ i 1))。所以满足 (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)) 对 (triples s t u) 等同于满足下标 \(i+1,j+1,k+1\) 以后的序列。那么现在要考虑剩下的包含下标 \(i,j,k\) 的序列了，也就是包含 \(i\)、包含 \(i,j\)、包含 \(i,j,k\) 三种情况。
(define (triples s t u)
(cons-stream
(map stream-car (list s t u))
(interleave
(stream-map (lambda (k)
(list (stream-car s)
(stream-car t)
k))
(stream-cdr u))
(interleave
(stream-map (lambda (p)
(cons (stream-car s) p))
(pairs (stream-cdr t)
(stream-cdr u)))
(triples (stream-cdr s)
(stream-cdr t)
(stream-cdr u))))))
(define pythagorean-triples
(stream-filter (lambda (triple)
(= (square (caddr triple))
(+ (square (cadr triple))
(square (car triple)))))
(triples integers integers integers)))
当然这个算法效率是很低的。
3.70
(define (merge-weighted weighting-function s1 s2)
(let recu ([s1 s1]
[s2 s2])
(cond [(stream-null? s1) s2]
[(stream-null? s2) s1]
[else
(let ([s1car (stream-car s1)]
[s2car (stream-car s2)])
(let ([w1 (weighting-function s1car)]
[w2 (weighting-function s2car)])
(cond [(> w1 w2)
(cons-stream
s2car
(recu s1
(stream-cdr s2)))]
[else
(cons-stream
s1car
(recu (stream-cdr s1)
s2))])))])))
(define (pairs-weighted weighting-function s t)
(cons-stream
(list (stream-car s) (stream-car t))
(merge-weighted
weighting-function
(stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(pairs-weighted weighting-function
(stream-cdr s) (stream-cdr t)))))
(pairs-weighted (lambda (p)
(+ (car p) (cadr p)))
integers integers)
(let ([gen (stream-filter
(lambda (i)
(not (memq i '(2 3 5))))
integers)])
(pairs-weighted (lambda (p)
(let ([i (car p)]
[j (cadr p)])
(+ (* 2 i) (* 3 j) (* 5 i j))))
gen gen))
3.71
(define (zip . streams)
(apply stream-map (cons list streams)))
(define (remove-duplicates stream)
(let hold ([c (stream-car stream)]
[stream (stream-cdr stream)])
(cond [(stream-null? stream)
(cons-stream c the-empty-stream)]
[(= c (stream-car stream))
(hold c (stream-cdr stream))]
[else
(cons-stream c (remove-duplicates stream))])))
(define (cube-sum i j)
(+ (* i i i) (* j j j)))
(define Ramanujan-numbers
(remove-duplicates
(let* ([gen (pairs-weighted (lambda (p)
(cube-sum (car p) (cadr p)))
integers
integers)]
[s1 (stream-map (lambda (p)
(cube-sum (car p) (cadr p)))
gen)]
[s2 (stream-cdr s1)])
(stream-map car
(stream-filter (lambda (lst)
(= (car lst) (cadr lst)))
(zip s1 s2))))))
3.72
(define (square-sum i j)
(+ (* i i) (* j j)))
(define sum-of-two-squares-in-three-different-ways
(remove-duplicates
(let* ([gen (pairs-weighted (lambda (p)
(square-sum (car p) (cadr p)))
integers
integers)]
[s1 (stream-map (lambda (p)
(square-sum (car p) (cadr p)))
gen)]
[s2 (stream-cdr s1)]
[s3 (stream-cdr s2)])
(stream-map car
(stream-filter (lambda (lst)
(= (car lst)
(cadr lst)
(caddr lst)))
(zip s1 s2 s3)))))
3.73
(define ((RC R C dt) v0 is)
(define cv
(cons-stream
v0
(add-streams (scale-stream is
(/ dt C))
cv)))
(add-streams cv (scale-stream is R)))
(define ((RC R C dt) v0 is)
(add-stream (integral (scale-stream is (/ C)) v0 dt)
(scale-stream is R)))
3.74
(define zero-crossings
(stream-map sign-change-detector
sense-data
(cons-stream 0 sense-data)))
3.75
(define (make-zero-crossings input-stream last-value last-avpt)
(let ([avpt (/ (+ (stream-car input-stream)
last-value)
2)])
(cons-stream
(sign-change-detector avpt last-avpt)
(make-zero-crossings
(stream-cdr input-stream)
(stream-car input-stream)
avpt))))
3.76
(define (smooth stream)
(stream-map average
(stream-cdr stream)
stream))
(define zero-crossings
(make-zero-crossings (smooth sense-data) 0))
3.77
(define (integral delayed-integrand initial-value dt)
(cons-stream
initial-value
(let ([integrand (force delayed-integrand)])
(if (stream-null? integrand)
the-empty-stream
(integral (delay (stream-cdr integrand))
(+ (* dt (stream-car integrand))
initial-value)
dt)))))
3.78
(define (solve-2nd y0 dy0 a b dt)
(define y (integral (delay dy) y0 dt))
(define dy (integral (delay ddy) dy0 dt))
(define ddy (add-streams (scale-stream dy a)
(scale-stream y b)))
y)
3.79
(define (solve-2nd f y0 dy0 dt)
(define y (integral (delay dy) y0 dt))
(define dy (integral (delay ddy) dy0 dt))
(define ddy (stream-map f dy y))
y)
3.80
(define ((RLC R L C dt) vC0 iL0)
(define vC (integral (delay dvC) vC0 dt))
(define iL (integral (delay diL) iL0 dt))
(define dvC (scale-stream iL (/ -1 C)))
(define diL (add-streams (scale-stream vC (/ L))
(scale-stream iL (/ R L -1))))
(stream-map cons vC iL))
3.81
(define (random-update x)
(remainder (+ (* 1103515245 x)
12345)
4294967087))
(define (make-random-gen init-value)
(define gen
(cons-stream (random-update init-value)
(stream-map random-update gen)))
gen)
(define (make-random request-stream)
(let handler ([request-stream request-stream]
[random-stream (make-random-gen 0)])
(if (stream-null? request-stream)
the-empty-stream
(let ([request (stream-car request-stream)])
(cond [(eq? request 'generate)
(cons-stream
(stream-car random-stream)
(handler (stream-cdr request-stream)
(stream-cdr random-stream)))]
[(eq? (car request) 'reset)
(cons-stream
#t
(handler (stream-cdr request-stream)
(make-random-gen (cdr request))))]
[else (error "unknown request" request)])))))
如果想要 reset 时不输出，可以删去 cons-stream #t 只保留 (handler ....)。此时 generate 和 reset 具有相似的结构，可以优化为
(define (make-random request-stream)
(define (handle-request request value)
(cond [(eq? request 'generate)
(random-update value)]
[(eq? (car request) 'reset)
(random-update (cdr request))]
[else (error "unknown request" request)]))
(define result
(cons-stream (random-update 0)
(stream-map handle-request
request-stream
result)))
result)
测试
(stream->list
(make-random
(list->stream '(generate generate generate
(reset . 0)
generate generate generate
(reset . 1)
generate generate generate))))
3.82
(define (estimate-integral pred x1 x2 y1 y2)
(define random-pair-gen
(let gen ()
(cons-stream (cons (random 1.) (random 1.))
(gen))))
(monte-carlo (stream-map pred random-pair-gen)
0 0))
(define π-stream
(scale-stream (estimate-integral
(lambda (p)
(> 1 (+ (square (car p))
(square (cdr p)))))
-1 1 -1 1)
4.))
或者
(define (estimate-integral pred x1 x2 y1 y2)
(define (random-gen)
(cons-stream (random 1.) (random-gen)))
(define (scale-random-gen lower-bound upper-bound)
(add-streams (scale-stream (random-gen)
(- upper-bound lower-bound))
(scale-stream ones
lower-bound)))
(monte-carlo (stream-map pred
(scale-random-gen x1 x2)
(scale-random-gen y1 y2))
0 0))
(define π-stream
(scale-stream (estimate-integral
(lambda (x y)
(> 1 (+ (square x)
(square y))))
-1 1 -1 1)
4.))
