4.1
这道题强调的还是时间顺序，一种类似流的想法，所以我们可以强制性的设定变量进行求值。
从左往右
(define (list-of-values exps env)
(if (not-operands? exps)
'()
(let ((first (eval (first-operand exps) env)))
(cons first
(list-of-values (rest-operands exps) env)))))
从右往左
(define (list-of-values exps env)
(if (not-operands? exps)
'()
(let ((last (list-of-values (rest-operands exps) env)))
(cons (eval (first-operand exps) env)
last))))
4.2
a:错误在于执行过程语句检测时，语句都会被视作过程调用来执行。(define x 3)时会在环境中寻找同名的并尝试赋值。
b:简单仿写一下检测call的cond语句就好了。
((call? exp) (apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
4.3
(define (eval exp env)
(if (self-evaluating? exp)
exp
(let ((eval-proc (get 'eval (expression-type exp))))
(eval-proc (expression-content exp)
env))))
后续用put进行添加操作
4.4
这道题的中文解答没看明白，特别是它突然加了一个and-eval却完全不解释来源，于是去英文源找了答案，选择了一个比较好理解的版本
((and? exp) (eval-and exp env))
(define (eval-and exp env)
(cond ((null? exp) #t)
(else
(let ((first (eval (first-exp exp) env)))
(cond ((last-exp? exp) first)
(first (eval-and (rest-exp exp) env))
(else #f))))))
我们对if也能这样操作
((or? exp) (eval-or exp env))
(define (eval-or exp env)
(cond ((null? exp) #t)
(else
(let ((first (eval (first-exp exp) env)))
(cond ((last-exp? exp) first)
((not first) (eval-or (rest-exp exp) env))
(else #t))))))
4.5
(define (extended-cond-syntax? clause) (eq? (cadr clause) '=>))
(define (extended-cond-test clause) (car clause))
(define (extended-cond-recipient clause) (caddr clause))
(define (expand-clauses clauses)
(if (null? clauses)
'false
(let ((first (car clauses))
(rest (cdr clauses)))
(cond ((cond-else-clause? first)
(if (null? rest)
(sequense->exp (cons-actions first))
(error "ELSE clause isn't last -- COND->IF"
clauses)))
((extended-cond-syntax? first)
(make-if (extended-cond-test first)
(list (extended-cond-recipient first) (extended-cond-test first))
(expand-clauses rest)))
(else
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest)))))))
4.6
(define (let->combination exp)
(let ((value (map car (let-var-and-exp exp)))
(expr (map cdr (let-var-and-exp exp))))
(list (make-lambda value (let-body exp)) expr)))
((let? exp);add it to eval
(eval (let->combination exp) env))
4.7
(define (let*? expr) (tagged-list? expr 'let*))
(define (let*-body exp) (caddr exp))
(define (let*-exp exp) (cadr exp))
(define (let*->nested-lets exp)
(let ((expr (let*-exp exp))
(body (let*-body exp)))
(define (make-let exps)
(if (null? exps)
body
(list 'let (list (car exps)) (make-lets (cdr exps)))))
(make-let exp)))
4.8
(define (let-var exp)
(cadr exp))
(define (let-body exp)
(cadddr exp))
(define (let-param exp)
(map car (caddr exp)))
(define (let-argv exp)
(map cadr (caddr exp)))
(define (let-command? exp)
(and (let? exp) (symbol? (cadr exp))))
(define (let->func exp)
(list 'define
(cons (let-var exp)
(let-param exp))
(let-body exp)))
(define (let->combination exp)
(if (let-command? exp)
(sequence->exp
(list (let->func exp)
(cons (let-var exp) (let-argv exp))
(cons (make-lambda (map car (cadr exp))
(list (let-body exp)))
(let-argv exp))))
(let ((value (map car (let-var-and-exp exp)))
(expr (map cdr (let-var-and-exp exp))))
(list (make-lambda value (let-body exp)) expr))))
4.9
参考习题集
以 do 结构为例子，根据 R5RS ， do 的定义如下：
(do ((<variable1> <init1> <step1>)
...)
(<test1> <expression1> ...)
<command> ...)
它可以转换为：
(define (iter <var1> <var2> ... <varN>)
(cond ((<test1> <expression1>)
(<test1> <expression1>)
...
(else
(iter (<step1> <var1>)
(<step2> <var2>)
...
(<stepN> <varN>))))))
(iter <init1> <init2> ... <initN>)
其中的 iter 必须是一个随机产生的，无重复的名字
4.10
参考习题解
要修改具体的表示，只要修改选择函数和构造函数就可以了， eval 和 apply 完全不必修改。
新的表示可以用 cons 来做，比如 (quote hello) 可以这样来实现：
(cons 'quote hello)
而不是原来的
(list 'quote hello)
同样的，如果我们想要中缀或者后缀式的话，修改相应构造函数，或者选择函数即可。
4.11
(define (make-frame vars vals)
(list vars vals))
(define (frame-vars frame)
(car frame))
(define (frame-vals frame)
(cadr frame))
(define (set-frame-vars! frame new-vars)
(set-car! frame new-vars))
(define (set-frame-vals! frame new-vals)
(set-car! (cdr frame) new-vals))
(define (add-binding-to-frame! var val frame)
(set-frame-vars! frame (cons var (frame-vars frame)))
(set-frame-vals! frame (cons val (frame-vals frame))))
4.12
(define (env-loop var env)
(define (scan vars vals)
(cond ((null? vars)
false)
((eq? var (car vars))
vals)
(else
(scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((vals (scan (frame-variables (first-frame env))
(frame-values (first-frame env)))))
(if vals
vals
(env-loop var (enclosing-environment env))))))
(define (lookup-variable-value var env)
(car (env-loop var env)))
(define (set-variable-value! var val env)
(set-car! (env-loop var env) val))
(define (define-variable! var val env)
(let ((vals (scan (frame-variables (first-frame env))
(frame-values (first-frame env)))))
(if vals
(set-car! vals val)
(add-binding-to-frame! var val frame))))
4.13
应该删去遇到的第一个符号的地方，总不能删一个函数的局部变量里的而把全局变量也删了
(define (make-bound！ var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(begin (set! vars (cdr vars))
(set! vals (cdr vals))))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
对着lookup-variable-value过程进行了修改。
4.14
这是因为输入的(map proc seq)中的proc会带有primitive的标记，map想要的是一个过程，而不是列表。
4.15
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_15.md
这是著名的停机问题。采用反证法。
假设可以正确实现 halt?, (halt? try try) 就会返回 true 或者 false。
情况 1
假如 (halt? try try) 返回 true, 就表示 (try try) 会停机。但我们展开 (try try) 的计算过程为
(if (halt? try try) ; true
(run-forever)
‘halted)
很明显，判断后，会进入 (run-forever), (try try) 是不会停机的。跟 (halt? try try) 返回 true 矛盾。
情况 2
假如 (halt? try try) 返回 false，就表示 (try try) 不会停机。但我们展开 (try try) 的计算过程为：
(if (halt? try try) ; false
(run-forever)
‘halted)
很明显，判断后，会返回 ‘halted，(try try) 会停机。跟 (halt? try try) 返回 false 矛盾。
结论
(halt? try try) 无论返回 true，还是返回 false 都会产生矛盾。因而，最原始的假设不成立，并不能正确实现 halt? 函数。万能的停机 halt? 函数不存在。
4.16
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(if (eq? (car vals) '*unassigned*)
(error "variable is unassigned" var)
(car vals)))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_16.md
(define (filter predicate sequence)
(if (null? sequence)
'()
(if (predicate (car sequence))
(cons (car sequence) (filter predicate (cdr sequence)))
(filter predicate (cdr sequence)))))
(define (scan-out-defines body)
(define (body-defines body)
(filter definition? body))
(define (name-unassigned defines)
(map (lambda (exp)
(list (definition-variable exp) ''*unassigned*))
defines))
(define (defines->let-body body)
(map (lambda (exp)
(if (definition? exp)
(list 'set! (definition-variable exp) (definition-value exp))
exp))
body))
(let ((defines (body-defines body)))
(if (null? defines)
body
(list (append (list 'let (name-unassigned defines))
(defines->let-body body))))))
在 make-procedure 中安装 scan-out-defines，这样只需要转换一次。假如安装在 procedure-body 中，每次获取 body，都需要重复调用 scan-out-defines。
make-procedure 的实现修改为：
(define (make-procedure parameters body env)
(list 'procedure parameters (scan-out-defines body) env))
4.17
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_17.md
转换后代码为
(lambda <vars>
(let ((u '*unassigned*)
(v '*unassigned*))
(set! u <e1>)
(set! v <e2>)
<e3>))
见 练习 4.6, let 语法只是 lambda 的派生表达式。每个 let 语句会对应一个 lambda。而执行 lambda 会产生多一个环境框架。因此变换后的代码，会比之前多一个框架。
b)
见上图，变换后的代码，执行 \
因而变换后的代码，就算多了一个框架，也不会影响程序的执行。
c)
要不产生更多的框架，scan-out-defines 可以将所有的 define 语句放到最前面。比如
(
(define a 1)
(+ a b)
(define b 1)
)
就转换为
(
(define a 1)
(define b 1)
(+ a b)
)
其实现为
(define (filter predicate sequence)
(if (null? sequence)
'()
(if (predicate (car sequence))
(cons (car sequence) (filter predicate (cdr sequence)))
(filter predicate (cdr sequence)))))
(define (scan-out-defines body)
(define (body-defines body)
(filter definition? body))
(define (body-not-defines body)
(filter (lambda (exp) (not (definition? exp))) body))
(let ((defines (body-defines body)))
(if (null? defines)
body
(append (body-defines body) (body-not-defines body)))))
对比 练习 4.16 中 scan-out-defines 的实现，两者行为是有不同的。练习 4.16 中的实现，会保留语句的顺序，假如执行
(define (f)
(define a 1)
(+ a b)
(define b 1))
(f)
因为 b 还没有赋值，会产生错误 variable is unassigned b。
而这里的实现，为了省略一个框架，将 define 语句都调整到前面。上面测试代码会执行成功，结果为 2。
我认为练习 4.16中的实现，保留语句顺序会更加合理。调整语句顺序，会产生某些意外行为。
4.18
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_18.md
可以在 P241 – 3.5.4 的基础上修改测试。改写 solve 函数。
(define (solve f y0 dt)
(define y (integral (delay dy) y0 dt))
(define dy (stream-map f y))
y)
(define (solve2 f y0 dt)
(let ((y '*unassigned*)
(dy '*unassigned*))
(set! y (integral (delay dy) y0 dt))
(set! dy (stream-map f y))
y))
(define (solve3 f y0 dt)
(let ((y '*unassigned*)
(dy '*unassigned*))
(let ((a (integral (delay dy) y0 dt))
(b (stream-map f y)))
(set! y a)
(set! dy b))
y))
其中 solve 是原始的函数，solve2 是正文使用的转换，solve3 是本题目使用的转换。
测试后可知道，solve2 可以正确工作。而 solve3 会失败，返回错误信息
car: contract violation
expected: pair?
given: '*unassigned
```
原因:solve3 的错误信息，发生在内层的 let 语句中。
```scheme
(let ((a (integral (delay dy) y0 dt))
(b (stream-map f y))) ;; 这条语句发生错误
xxx)
</code></pre>
(stream-map f y) 尽管里面使用 delay, 但还是需要立即求值第一个元素，于是也就需要求值 (car y)。但是这时 y 还没有被赋值，y 的值还是 <em>unassigned</em>, 因此就发生了错误。
solve2 可以正确工作。下面语句依次执行
<pre><code class="language-scheme line-numbers">(set! y (integral (delay dy) y0 dt))
(set! dy (stream-map f y))
</code></pre>
当调用 (stream-map f y) ，需要求值 (car y) 时, 这时候 y 已经被正确赋值了。
注意到，solve2、solve3 中的 (integral (delay dy) y0 dt) 语句都不会发生错误。因为 (delay dy) 语句中的 dy 并不需要立即求值。
<h2>4.19</h2>
<blockquote>
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_19.md
</blockquote>
我支持 Alyssa 的观点。
Ben 的观点从顺序执行的角度是最自然的，但没有考虑作用域。让外部的作用域影响了内层的作用域，或者让内层作用域覆盖外层作用域。可能会产生难以发现的问题。按照 Ben 的做法，下面的语句不能执行
<pre><code class="language-scheme line-numbers">(define (f x)
(define b (+ a x))
(define a 5)
(+ a b))
(f 10)
</code></pre>
但外层定义了 a 之后，就可以执行成功。这时下面两个语句中
<pre><code class="language-scheme line-numbers">(define b (+ a x))
(+ a b)
</code></pre>
处于相同的作用域，但看到的具体 a 变量是完全不同的。内层的 a 覆盖了外层的 a，他们处于相同的作用域，使用同一个符合，但是含义却不相同，这会无意中产生一些难以发现的问题。
Eva 的观点中。在相同作用域内，define 的顺序是任意的，define 语句可以不讲究顺序。但这种方法难以实现，需要自动分析 define 语句的相互依赖。另外我们看代码，习惯从上到下，顺序语句更容易理解。Eva 的观点中，后面的 define 语句会影响前面的语句结果，这不符合代码顺序执行，这种直观。人们更容易理解顺序，更难理解同时。
Alyssa 的观点，其实是正文的做法，同时考虑了作用域和顺序执行。它遵守下面规则。
同一作用域下，相同符号的变量含义相同，访问同一个变量。
在符合规则 1 的情况下，代码顺序执行。
这种规则相对容易理解，也容易实现。按照 Alyssa 的观点，习题中的代码会发生错误，强迫程序员编写更好的代码。
Eva 定义的方案，define 可以不讲究顺序，是完全同时的。要实现这种概念上的同时性（但解释器实际是顺序执行的），就需要调整 define 语句的顺序。将所有的 define 放到作用域的前面。另外需要分析 define 语句的依赖关系，构成一个依赖图，让依赖越小的越靠前。这个依赖分析有点麻烦，类似于预先运行解释器一次。
<h2>4.20</h2>
<blockquote>
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_20.md
</blockquote>
<pre><code class="language-scheme line-numbers">((letrec? exp) (eval (letrec->let exp) env));add it to eval
(define (letrec? exp) (tagged-list? exp 'letrec))
(define (letrec->let exp)
(define (letrec-body exp) (cddr exp))
(define (name-unassigned exp)
(map (lambda (pair) (list (car pair) ''*unassigned*)) (cadr exp)))
(define (name-sets exp)
(map (lambda (pair) (list 'set! (car pair) (cadr pair))) (cadr exp)))
(append (list 'let (name-unassigned exp))
(append (name-sets exp) (letrec-body exp))))
</code></pre>
<img src="http://useradd.me/wp-content/uploads/2025/01/exercise_4_20.png" alt="" />
区别在于 even? 和 odd? 关联的最内层环境。
使用 letrec，如左图所示，环境指向 E1，因而执行过程体中的语句，可以顺利找到 even? 和 odd? 的定义。
使用 let 时，如右图所示，环境指向 E2, 执行语句时，就找不到 even? 和 odd? 的定义，从而出错。
<h2>4.21</h2>
<pre><code class="language-scheme line-numbers">((lambda (n)
((lambda (fact)
(fact fact n))
(lambda (ft k)
(if (= k 1)
1
(* k (ft ft (- k 1)))))))
10)
((lambda (fact)
(fact fact 10))
(lambda (ft k)
(if (= k 1)
1
(* k (ft ft (- k 1))))))
((lambda (fact)
(fact fact 10))
(lambda (ft k)
(if (= k 1)
1
(* k (ft ft (- k 1))))))
(* 10 (fact fact 9))
(* 10 (* 9 (fact fact 8)))
</code></pre>
两个fact可视为调用时将自身也调过去以备下次调用
<pre><code class="language-scheme line-numbers">((lambda (n)
((lambda (fib)
(fib fib n))
(lambda (ft k)
(cond ((= k 0)
0)
((= k 1)
1)
(else
(+ (ft ft (- k 1)) (ft ft (- k 2))))))))
a-n-to-get);you can change it to the number you like
</code></pre>
<pre><code class="language-scheme line-numbers">(define (f x)
((lambda (even? odd?)
(even? even? odd? x))
(lambda (ev? od? n)
(if (= n 0) true (od? ev? od? (- n 1))))
(lambda (ev? od? n)
(if (= n 0) false (ev? ev? od? (- n 1))))))
</code></pre>
<h2>4.22</h2>
<pre><code class="language-scheme line-numbers">((let? exp) (analyze-let exp))
(define (analyze-let exps)
(analyze-lambda (let->combination exps)))
</code></pre>
<h2>4.23</h2>
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_23.md
Alyssa 实现的版本中，序列中每个表达式虽然经过分析，但序列本身并没有经过分析，计算时需要动态循环序列本身。
正文给出的版本，序列中的表达式经过分析，序列本身也经过分析。计算序列时，并不需要循环，计算序列那个循环被优化了。
a) 序列只有一个表达式
假如序列只有一个最简单的表达式
<pre><code class="language-scheme line-numbers">'Hello
</code></pre>
这个表达式本身，在两个版本中都被分析为
<pre><code class="language-scheme line-numbers">(lambda (env) 'Hello)
</code></pre>
Alyssa 实现的版本，分析序列后，返回相当于
<pre><code class="language-scheme line-numbers">(lambda (env) (execute-sequence (list
(lambda (env) 'Hello)
)
env))
</code></pre>
可以看到，execute-sequence 传入分析后表达式列表，求值 execute-sequence 需要循环列表本身。而正文中实现的版本，分析序列的结果为
<pre><code class="language-scheme line-numbers">(lambda (env) 'Hello)
</code></pre>
可以看到，直接返回序列中的表达式本身，不需要经过任何循环。
假如序列有两个表达式
<pre><code class="language-scheme line-numbers">'Hello
'World
</code></pre>
表达式本身，在两个版本中都被分析为
<pre><code class="language-scheme line-numbers">(lambda (env) 'Hello)
(lambda (env) 'World)
</code></pre>
Alyssa 实现的版本，分析序列后，返回相当于
<pre><code class="language-scheme line-numbers">(lambda (env) (execute-sequence (list
(lambda (env) 'Hello)
(lambda (env) 'World)
)
env))
</code></pre>
跟一个表达式时，没有太大区别，execute-sequence 需要循环列表。而正文中实现的版本，分析序列后，会将分析后的表达式连锁起来。返回
<pre><code class="language-scheme line-numbers">(lambda (env)
((lambda (env) 'Hello) env)
((lambda (env) 'World) env))
c) ;序列有更多表达式
'Hello
'World
'Hello
'World
</code></pre>
Alyssa 实现的版本，就算更多表达式，也跟之前差不多。execute-sequence 需要循环列表。
而正文的版本，连锁表达式后，分析结果相当于
<pre><code class="language-scheme line-numbers">(lambda (env)
((lambda (env)
((lambda (env)
((lambda (env) 'Hello) env)
((lambda (env) 'World) env)) env)
((lambda (env) 'Hello) env)) env)
((lambda (env) 'World) env))
</code></pre>
正文的版本，就算有再多的表达式，也会将分析后的表达式连锁起来。其分析结果是完全没有循环的，直接调用，将循环表达式优化掉了。
<h2>4.24</h2>
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_24.md
修改 mceval.scm, 在 driver-loop 中添加计时。
<pre><code class="language-scheme line-numbers">(
(define (driver-loop)
(prompt-for-input input-prompt)
(let* ((input (read))
(star-time (current-inexact-milliseconds)))
(let ((output (eval input the-global-environment)))
(announce-output (- (current-inexact-milliseconds) star-time))
(announce-output output-prompt)
(user-print output)))
(driver-loop))
</code></pre>
写一段测试代码，累计求和，并循环多次。这样两个函数 sum、loop，里面都有递归。
<pre><code class="language-scheme line-numbers">(begin
(define (sum a b)
(if (= a b)
a
(+ (sum a (- b 1)) b)))
(define (loop n f)
(cond ((> n 0)
(f)
(loop (- n 1) f))))
(loop 1000 (lambda () (sum 1 1000))))
</code></pre>
测试代码循环多次。分析再求值中，无论循环执行多少次，分析也只是一次。
于是忽略误差（分析只有一次，可忽略其时间），5.738 秒是纯粹的执行时间。而原来的求值器中，每次循环都需要分析和执行，于是分析加执行的时间为 12.372 秒。
大概可看出，此例中，分析和执行的时间大概是一半一半。
<h2>4.25</h2>
在应用序会导致死循环，而在正则序能正常运行并返回120
<h2>4.26</h2>
a) unless 可以实现成 if 的派生表达式。比如
<pre><code class="language-scheme line-numbers">(unless (= b 0)
(/ a b)
(begin (display "exception: returning 0")
0))
(define (factorial n)
(unless (= n 1)
(* n (factorial (- n 1)))
1))
</code></pre>
可以转换为
<pre><code class="language-scheme line-numbers">(if (= b 0)
(begin (display "exception: returning 0")
0)
(/ a b))
(define (factorial n)
(if (= n 1)
1
(* n (factorial (- n 1)))))
</code></pre>
b)
<pre><code class="language-scheme line-numbers">(define select-y '(#t #f #t #t))
(define xs '(1 3 5 7))
(define ys '(2 4 6 8))
(define selected (map unless select-y xs ys))
</code></pre>
在上面代码中，unless 作为了 map 的参数。假如 unless 实现为过程，上面代码可以正常运行。但假如将 unless 实现成派生表达式，代码就运行不了。
<h2>4.27</h2>
<pre><code class="language-scheme line-numbers">1
10
2
</code></pre>
定义 w 时，只调用了 id 过程一次。count 变为1。求值 w 时，触发了 force-it，让之前的 (id 10) 表达式强制求值了，count变为2
<h2>4.28</h2>
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_28.md
照题目意思将 eval 中的 application? 分支修改成：
<pre><code class="language-scheme line-numbers">((application? exp)
(apply (eval (operator exp) env) ; 将 actual-value 改成 eval
(operands exp)
env))
</code></pre>
下面测试代码就会出错
<pre><code class="language-scheme line-numbers">(define (f op)
op)
((f +) 1 2)
</code></pre>
在惰性求值中 (f +) 的返回被封装成 thunk。
<pre><code class="language-scheme line-numbers">('thunk + env)
</code></pre>
假如直接使用 eval 而不是 actual-value，测试代码会触发 apply 中的 error。
<pre><code class="language-scheme line-numbers">Unknown procedure type -- APPLY (thunk + #0=(( xxxxx
</code></pre>
<h2>4.29</h2>
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_29.md
在 driver-loop 中添加计时。
<pre><code class="language-scheme line-numbers">(
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read))
(star-time (current-inexact-milliseconds)))
(let ((output
(actual-value input the-global-environment)))
(announce-output (- (current-inexact-milliseconds) star-time))
(announce-output output-prompt)
(user-print output)))
(driver-loop))
</code></pre>
下面的测试代码
<pre><code class="language-scheme line-numbers">(begin
(define (power x n)
(if (= n 1)
x
(* x (power x (- n 1)))))
(power (power 1 100) 1000)
)
</code></pre>
在同一机器上，分别打开和关闭 force-it 的记忆功能。
在有记忆功能下，求值时间为 0.014 秒。
在没有记忆功能下，求值时间为 22.203 秒。
b)
<pre><code class="language-scheme line-numbers">(define count 0)
(define (id x)
(set! count (+ count 1))
x)
(define (square x)
(* x x))
```
在有记忆功能时
```scheme
;;; L-Eval input:
(square (id 10))
;;; L-Eval value:
100
;;; L-Eval input:
count
;;; L-Eval value:
1
</code></pre>
在没有记忆功能时
<pre><code class="language-scheme line-numbers">;;; L-Eval input:
(square (id 10))
;;; L-Eval value:
100
;;; L-Eval input:
count
;;; L-Eval value:
2
</code></pre>
在有记忆功能下，(id 10) 只被调用 1 次，count 为 1。
在没有记忆功能时，(id 10) 被调用了 2 次，count 为 2。
<h2>4.30</h2>
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_30.md
a)在求值 eval-sequence 时，序列的每个表达式都被 eval。而下面的语句中
<pre><code class="language-scheme line-numbers">(proc (car items)
</code></pre>
是一个过程调用，会对 proc 应用 actual-value，从而强制求值 proc，在此例中就是那个 lambda 表达式。
对 lambda 求值，又会再次触发 eval-sequence。newline 和 display 都是系统基本过程。在求值 display 基本过程时，每个参数都会被 actual-value 来求值，actual-value 会调用 force-it，获取到 x 的真正值。
b)
对于原来的 eval-sequence，两个表达式的结果如下
<pre><code class="language-scheme line-numbers">(p1 1) ;; (1 2)
(p2 1) ;; 1
</code></pre>
按照 Cy 的建议修改后的 eval-sequence，结果如下
<pre><code class="language-scheme line-numbers">(p1 1) ;; (1 2)
(p2 1) ;; (1 2)
</code></pre>
两者结果的差异在于 p2 中 e 语句的处理不同。
<pre><code class="language-scheme line-numbers">(define (p2 x)
(define (p e)
e ; 这里的处理不同
x)
(p (set! x (cons x '(2)))))
</code></pre>
e 对应于 (set! x (cons x '(2))) 语句，被延迟求值了。这个 e 本身有副作用。
对于原来的 eval-sequence，e 被调用 eval，e 对应于一个 thunk，并没有被真正求值。于是没有触发副作用来改变 x, x 仍然是原来 1。
而 Cy 的建议修改后的 eval-sequence，e 会被调用 actual-value，真正求值。触发了副作用，修改了 x，于是 x 的结果为 (cons 1 '(2))。也就是列表 (1 2)。
c)正如 a) 所解释的，for-each 中传入的 proc 参数，作为过程调用。
<pre><code class="language-scheme line-numbers">(proc (car items)
</code></pre>
对于过程调用的，proc 本身会被使用 actual-value，而不是应用 eval。而类似 b) 中的 e 表达式，只会使用 eval。
正是这点区别，让 Cy 的修改，对于类似 a) 中的 for-each 实例，其结果是一样的。
Cy 的修改，显示地让整个表达式 (proc (car items) 求值。而原来的实现，对 proc（对应传进来的 lambda）使用 actual-value 求值。两者都会触发对 lambda 内部的实现来求值。
d)我更喜欢原来的 eval-sequence 实现。
Cy 的方式有点激进，让序列中的中间表达式都强值求值，很可能导致本来并不需要求值的也被求值，就没有惰性的效果。
实际上，书中原始实现已经足够好。原始实现和 Cy 的建议，两者对于 for-each 的运行结果也是一致的。
for-each 这种代码很常见，而
<pre><code class="language-scheme line-numbers">(define (p2 x)
(define (p e)
e
x)
(p (set! x (cons x '(2)))))
```
这种代码本身就有点难以理解，现实中的程序是不建议这样写的。让过程参数带有副作用，本身就不好。
为了迁就本身就不够好的代码，而采用激进的方式，影响所有的序列求值效果。我认为是不值得的。
## 4.31
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_31.scm
```scheme
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((application? exp) ; clause from book
(apply (actual-value (operator exp) env)
(operands exp)
env))
(else
(error "Unknown expression type -- EVAL" exp))))
(define (actual-value exp env)
(force-it (eval exp env)))
(define (apply procedure arguments env)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure
procedure
(list-of-arg-values arguments env)))
((compound-procedure? procedure)
(eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
(list-of-delayed-args (cadr procedure) arguments env) ; 改了这里
(procedure-environment procedure))))
(else
(error
"Unknown procedure type -- APPLY" procedure))))
(define (list-of-arg-values exps env)
(if (no-operands? exps)
'()
(cons (actual-value (first-operand exps) env)
(list-of-arg-values (rest-operands exps)
env))))
(define (lazy-parameter? x)
(and (pair? x) (eq? (cadr x) 'lazy)))
(define (lazy-memo-parameter? x)
(and (pair? x) (eq? (cadr x) 'lazy-memo)))
(define (procedure-parameters p)
(map (lambda (x)
(cond ((lazy-parameter? x) (car x))
((lazy-memo-parameter? x) (car x))
(else x)))
(cadr p)))
(define (list-of-delayed-args parameters exps env)
(if (no-operands? exps)
'()
(cons (delay-it (car parameters) (first-operand exps) env)
(list-of-delayed-args (cdr parameters)
(rest-operands exps)
env))))
(define (eval-if exp env)
(if (true? (actual-value (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
(define input-prompt "Lazy-Eval input:")
(define output-prompt "Lazy-Eval value:")
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read)))
(let ((output
(actual-value input the-global-environment)))
(announce-output output-prompt)
(user-print output)))
(driver-loop))
;;; Representing thunks
;; thunks
(define (delay-it parameter exp env)
(cond ((lazy-parameter? parameter) (list 'thunk exp env))
((lazy-memo-parameter? parameter) (list 'thunk-memo exp env))
(else (actual-value exp env))))
(define (thunk? obj) (tagged-list? obj 'thunk))
(define (thunk-memo? obj) (tagged-list? obj 'thunk-memo))
(define (thunk-exp thunk) (cadr thunk))
(define (thunk-env thunk) (caddr thunk))
;; "thunk" that has been forced and is storing its (memoized) value
(define (evaluated-thunk? obj)
(tagged-list? obj 'evaluated-thunk))
(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))
(define (force-it obj)
(cond ((thunk? obj)
(actual-value (thunk-exp obj) (thunk-env obj)))
((thunk-memo? obj)
(let ((result (actual-value (thunk-exp obj) (thunk-env obj))))
(set-car! obj 'evaluated-thunk)
(set-car! (cdr obj) result) ; replace exp with its value
(set-cdr! (cdr obj) '()) ; forget unneeded env
result))
((evaluated-thunk? obj)
(thunk-value obj))
(else obj)))
4.32
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_32.md
a)本节实现的惰性表，连表中第一个元素 car，也可惰性求值。第三章实现的流，第一个元素是需要立即求值的。
比如 练习 4.18 中，将 solve 改写成：
(define (solve f y0 dt)
(let ((y '*unassigned*)
(dy '*unassigned*))
(let ((a (integral (delay dy) y0 dt))
(b (stream-map f y)))
(set! y a)
(set! dy b))
y))
(stream-map f y) 在流中需要立即求值 y 的第一个元素。因而发生错误。而惰性表实现的相应版本：
(define (solve f y0 dt)
(let ((y '*unassigned*)
(dy '*unassigned*))
(let ((a (integral dy y0 dt))
(b (map f y)))
(set! y a)
(set! dy b))
y))
是可以正常求值的。在惰性表中，(map f y)的第一个元素也被延迟求值了。
b)惰性表的第一个元素也是惰性的，我们可以改变表中的初始值，从而修改整个序列。比如库中预先写好随机数序列
(define random-init 7)
(define random-numbers
(cons random-init
(map rand-update random-numbers)))
这个随机数序列，默认情况下，初始化值为 7。有时我们想在使用的时候，设置另一个初始值。可以这样写
(set! random-init 100)
(list-ref random-numbers 10)
用户就可以根据不同用途，设置初始值
4.33
(define (eval-quotation exp env)
(define (list->cons exp)
(if (null? exp)
''()
(list 'cons (list 'quote (car exp))
(list->cons (cdr exp)))))
(if (pair? (cadr exp))
(eval (list->cons (cadr exp)) env)
(cadr exp)))
4.34
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_34.scm
;; cons 使用了 *lazy-cons-m* 这个特别的名字，用于作为标记
(define (install-lazy-cons)
(actual-value '(begin
(define (cons x y) (lambda (*lazy-cons-m*) (*lazy-cons-m* x y)))
(define (car z) (z (lambda (p q) p)))
(define (cdr z) (z (lambda (p q) q))))
the-global-environment))
(define (lazy-cons? p)
(and (compound-procedure? p)
(pair? (procedure-parameters p))
(eq? (car (procedure-parameters p)) '*lazy-cons-m*)))
;; 假如列表元素太多，会用 ... 省略后面的。
;; 比如 (define ones (cons 1 ones)) ones，会打印出 (1 1 1 1 1 1 1 1 1 1 1 ...)
(define (lazy-cons-print object level)
(if (> level 10)
(display "...")
(let* ((env (procedure-environment object))
(first (force-it (lookup-variable-value 'x env)))
(rest (force-it (lookup-variable-value 'y env))))
(user-print first)
(cond ((lazy-cons? rest)
(display " ")
(lazy-cons-print rest (+ level 1)))
((not (null? rest))
(display " . ")
(user-print rest))))))
(define (user-print object)
(if (compound-procedure? object)
(if (lazy-cons? object)
(begin
(display "(")
(lazy-cons-print object 0)
(display ")")
)
(display (list 'compound-procedure
(procedure-parameters object)
(procedure-body object)
'<procedure-env>)))
(display object)))
(define (driver-loop)
(install-lazy-cons)
(prompt-for-input input-prompt)
(let ((input (read)))
(let ((output
(actual-value input the-global-environment)))
(announce-output output-prompt)
(user-print output)))
(driver-loop))
4.35
(define (an-integer-between x y)
(require (<= x y))
(amb x (an-integer-between (+ x 1) y)))
4.36
如果只是简单替换的话那么会先在k级里一直循环下去，同理j1级也是这样所以只能让i为底层，颠倒过来,并且只修改k的an-integer-between为an-integer-starting-from
(define (a-pythagorean-triple-between)
(let ((k (an-integer-starting-from 1)))
(let ((j (an-integer-between 1 k)))
(let ((i (an-integer-between 1 j)))
(require (= (+ (* i i) (* j j)) (* k k)))
(list i j k)))))
4.37
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_37.md
Ben 说得对。本题中描述的方法比练习 4.35 的方法，效率更高。
练习 4.35 中，有 i、j、k 三层嵌套搜索，而此题中的方法只有 i、j 两层嵌套搜索。k 的搜索直接被 sqrt 函数替代了。
当搜索的区间很大时，计算 sqrt 会比被直接遍历搜索快得多。并且区间越大，本题的方法效率提升越明显。
我们可以做个测量。在我的机器上，搜索 10 组元素，结果如下
| 区间 | 练习 4.35 的方法耗时 | 本题的方法耗时 |
|---|---|---|
| 1 到 100 | 1.223 秒 | 0.042 秒 |
| 1 到 200 | 6.611 秒 | 0.277 秒 |
| 1 到 400 | 25.183 秒 | 0.364 秒 |
每次测量时间会有波动。但也可以看出，本题的方法效率更高。
4.38
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_38.md
中文翻译错了。原文为
Modify the multiple-dwelling procedure to omit the requirement that Smith and Fletcher do not live on adjacent floors. How many solutions are there to this modified puzzle?
是指忽略掉，Smith 和 Fletcher 不住相邻层的要求。也就是在 multiple_dwelling.scm 的基础上，删除
(require (not (= (abs (- smith fletcher)) 1)))这个条件。
删除条件后，谜题有下面 5 组解。
((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))
((baker 1) (cooper 2) (fletcher 4) (miller 5) (smith 3))
((baker 1) (cooper 4) (fletcher 2) (miller 5) (smith 3))
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
((baker 3) (cooper 4) (fletcher 2) (miller 5) (smith 1))
4.39
不会，但是顺序会影响速度，我们可以视其为and类型的短路问题，最容易短路的放前面就可以最快检测情况是否成立
(require (not (= baker 5)))
(require (not (= cooper 1)))
(require (not (= fletcher 5)))
(require (not (= fletcher 1)))
(require (> miller cooper))
(require (not (= (abs (- smith fletcher)) 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(require (distinct? (list baker cooper fletcher miller smith)))
这样摆放速度最快。
4.40
(define (multiple-dwelling)
(let ((cooper (amb 2 3 4 5))
(miller (amb 1 2 3 4 5)))
(require (> miller cooper))
(let ((fletcher (amb 2 3 4)))
(require (not (= (abs (- fletcher cooper)) 1)))
(let ((smith (amb 1 2 3 4 5)))
(require (not (= (abs (- smith fletcher)) 1)))
(let ((baker (amb 1 2 3 4)))
(require (distinct? (list baker cooper fletcher miller smith)))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))))))
4.41
常规的意思原来是用非dfs的方法来执行，而我以为是抽象化。。
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_41.scm
(define (multiple-dwelling)
(define (ok? lst)
(let ((baker (list-ref lst 0))
(cooper (list-ref lst 1))
(fletcher (list-ref lst 2))
(miller (list-ref lst 3))
(smith (list-ref lst 4)))
(and (not (= baker 5))
(not (= cooper 1))
(not (= fletcher 5))
(not (= fletcher 1))
(> miller cooper)
(not (= (abs (- smith fletcher)) 1))
(not (= (abs (- fletcher cooper)) 1)))))
(map (lambda (lst)
(list (list 'baker (list-ref lst 0))
(list 'cooper (list-ref lst 1))
(list 'fletcher (list-ref lst 2))
(list 'miller (list-ref lst 3))
(list 'smith (list-ref lst 4))))
(filter ok? (permutations (list 1 2 3 4 5)))))
4.42
(define (half-true p1 p2)
(if p1
(not p2)
p2))
(define (distinct? items)
(cond ((null? items) true)
((null? (cdr items)) true)
((member (car items) (cdr items)) false)
(else (distinct? (cdr items)))))
(define (test)
(let ((betty (amb 1 2 3 4 5))
(ethel (amb 1 2 3 4 5))
(joan (amb 1 2 3 4 5))
(kitty (amb 1 2 3 4 5))
(mary (amb 1 2 3 4 5)))
(require (half-truth (= kitty 2) (= betty 3)))
(require (half-truth (= ethel 1) (= joan 2)))
(require (half-truth (= joan 1) (= ethel 5)))
(require (half-truth (= kitty 2) (= mary 4)))
(require (half-truth (= mary 4) (= betty 1)))
(require (distinct? (list betty ethel joan kitty mary)))
(list (list 'betty betty)
(list 'ethel ethel)
(list 'joan joan)
(list 'kitty kitty)
(list 'mary mary))))
4.43
(define (test)
(let ((Mary (amb 'Moore 'Downing 'Hall 'Barnacle 'Parker)))
(require (eq? Mary 'Moore))
(let ((Melissa (amb 'Moore 'Downing 'Hall 'Barnacle 'Parker)))
(require (eq? Melissa 'Barnacle))
(let ((Gabrielle (amb 'Moore 'Downing 'Hall 'Barnacle 'Parker)))
(require (not (memq Gabrielle (list Mary Melissa 'Barnacle))))
(let ((Lorna (amb 'Moore 'Downing 'Hall 'Barnacle 'Parker)))
(require (not (memq Lorna (list Mary Melissa Gabrielle 'Moore))))
(let ((Rosalind (amb 'Moore 'Downing 'Hall 'Barnacle 'Parker)))
(require (not (memq Rosalind (list Mary Melissa Gabrielle Lorna 'Hall))))
(require (cond
((eq? Gabrielle 'Hall) (eq? Rosalind 'Parker))
((eq? Gabrielle 'barnacle) (eq? Gabrielle 'Parker))
(else false)))
(list (list 'Mary Mary)
(list 'Gabrielle Gabrielle)
(list 'Lorna Lorna)
(list 'Rosalind Rosalind)
(list 'Melissa Melissa))))))))
((Mary Moore) (Gabrielle Hall) (Lorna Downing) (Rosalind Parker) (Melissa Barnacle))
;去掉约束条件为
((Mary Moore) (Gabrielle Hall) (Lorna Downing) (Rosalind Parker) (Melissa Barnacle))
((Mary Hall) (Gabrielle Moore) (Lorna Parker) (Rosalind Downing) (Melissa Barnacle))
4.44
比较朴素的写法
(define (eight-queen)
(let ((q1 (amb 1 2 3 4 5 6 7 8)))
(let ((q2 (amb 1 2 3 4 5 6 7 8)))
(require (not (= q1 q2)))
(require (not (or (= (- q1 1) q2) (= (+ q1 1) q2))))
(let ((q3 (amb 1 2 3 4 5 6 7 8)))
(require (not (or (= q1 q3) (= q2 q3))))
(require (not (or (= (- q2 1) q3) (= (+ q2 1) q3)
(= (- q1 2) q3) (= (+ q1 2) q3))))
(let ((q4 (amb 1 2 3 4 5 6 7 8)))
(require (not (or (= q1 q4) (= q2 q4) (= q3 q4))))
(require (not (or (= (- q3 1) q4) (= (+ q3 1) q4)
(= (- q2 2) q4) (= (+ q2 2) q4)
(= (- q1 3) q4) (= (+ q1 3) q4))))
(let ((q5 (amb 1 2 3 4 5 6 7 8)))
(require (not (or (= q1 q5) (= q2 q5) (= q3 q5) (= q4 q5))))
(require (not (or (= (- q4 1) q5) (= (+ q4 1) q5)
(= (- q3 2) q5) (= (+ q3 2) q5)
(= (- q2 3) q5) (= (+ q2 3) q5)
(= (- q1 4) q5) (= (+ q1 4) q5))))
(let ((q6 (amb 1 2 3 4 5 6 7 8)))
(require (not (or (= q1 q6) (= q2 q6) (= q3 q6) (= q4 q6) (= q5 q6))))
(require (not (or (= (- q5 1) q6) (= (+ q5 1) q6)
(= (- q4 2) q6) (= (+ q4 2) q6)
(= (- q3 3) q6) (= (+ q3 3) q6)
(= (- q2 4) q6) (= (+ q2 4) q6)
(= (- q1 5) q6) (= (+ q1 5) q6))))
(let ((q7 (amb 1 2 3 4 5 6 7 8)))
(require (not (or (= q1 q7) (= q2 q7) (= q3 q7) (= q4 q7) (= q5 q7) (= q6 q7))))
(require (not (or (= (- q6 1) q7) (= (+ q6 1) q7)
(= (- q5 2) q7) (= (+ q5 2) q7)
(= (- q4 3) q7) (= (+ q4 3) q7)
(= (- q3 4) q7) (= (+ q3 4) q7)
(= (- q2 5) q7) (= (+ q2 5) q7)
(= (- q1 6) q7) (= (+ q1 6) q7))))
(let ((q8 (amb 1 2 3 4 5 6 7 8)))
(require (not (or (= q1 q8) (= q2 q8) (= q3 q8) (= q4 q8) (= q5 q8) (= q6 q8) (= q7 q8))))
(require (not (or (= (- q7 1) q8) (= (+ q7 1) q8)
(= (- q6 2) q8) (= (+ q6 2) q8)
(= (- q5 3) q8) (= (+ q5 3) q8)
(= (- q4 4) q8) (= (+ q4 4) q8)
(= (- q3 5) q8) (= (+ q3 5) q8)
(= (- q2 6) q8) (= (+ q2 6) q8)
(= (- q1 7) q8) (= (+ q1 7) q8))))
(list (list 'q1 q1)
(list 'q2 q2)
(list 'q3 q3)
(list 'q4 q4)
(list 'q5 q5)
(list 'q6 q6)
(list 'q7 q7)
(list 'q8 q8)))))))))))
4.45
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_45.md
(parse '(the professor lectures to the student in the class with the cat))
得到 5 种可能结果。其中没有歧义的是”教授在给学生讲课。”但是 (in the class) 和 (with the cat) 根据不同的断句，意思会有不同。
(in the class)，可以修饰 student 或者是 lectures。(有 2 种可能)
(with the cat), 可以是 professor、student 或者是 class。(有 3 种可能)
其中原句的顺序是，
lectures、student
in the class、with the cat
语法分析中禁止交叉修饰，也就是不会出现 lectures in the class 和 student with the cat 这种情况，因为这种情况下介词交叉了。于是总的可能性是 2 * 3 – 1 = 5。
1
'(sentence
(simple-noun-phrase (article the) (noun professor))
(verb-phrase
(verb-phrase
(verb-phrase
(verb lectures)
(prep-phrase
(prep to)
(simple-noun-phrase (article the) (noun student))))
(prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))
意思是：
教授在给学生讲课。
在课堂上讲课。lectures in the class
教授带着猫。professor with the cat
2
'(sentence
(simple-noun-phrase (article the) (noun professor))
(verb-phrase
(verb-phrase
(verb lectures)
(prep-phrase (prep to) (simple-noun-phrase (article the) (noun student))))
(prep-phrase
(prep in)
(noun-phrase
(simple-noun-phrase (article the) (noun class))
(prep-phrase
(prep with)
(simple-noun-phrase (article the) (noun cat)))))))
意思是：
教授在给学生讲课。
在课堂上讲课。lectures in the class
课堂有只猫。class with the cat
3
'(sentence
(simple-noun-phrase (article the) (noun professor))
(verb-phrase
(verb-phrase
(verb lectures)
(prep-phrase
(prep to)
(noun-phrase
(simple-noun-phrase (article the) (noun student))
(prep-phrase
(prep in)
(simple-noun-phrase (article the) (noun class))))))
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))
意思是：
教授在给学生讲课。
学生在课堂上。student in the class
教授带着猫。professor with the cat
4
'(sentence
(simple-noun-phrase (article the) (noun professor))
(verb-phrase
(verb lectures)
(prep-phrase
(prep to)
(noun-phrase
(noun-phrase
(simple-noun-phrase (article the) (noun student))
(prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))
(prep-phrase
(prep with)
(simple-noun-phrase (article the) (noun cat)))))))
意思是：
教授在给学生讲课。
学生在课堂上。student in the class
学生带着猫。student with the cat
5
'(sentence
(simple-noun-phrase (article the) (noun professor))
(verb-phrase
(verb lectures)
(prep-phrase
(prep to)
(noun-phrase
(simple-noun-phrase (article the) (noun student))
(prep-phrase
(prep in)
(noun-phrase
(simple-noun-phrase (article the) (noun class))
(prep-phrase
(prep with)
(simple-noun-phrase (article the) (noun cat)))))))))
意思是：
教授在给学生讲课。
学生在课堂上。student in the class
课堂有只猫。class with the cat
4.46
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_46.md
我们的分析程序，将输入存储在*unparsed* 中，对句子从左往右分析。分析过程中，会修改 *unparsed* 的值。
于是分析程序是有状态的，之前的分析结果，会影响之后的分析结果。因为有状态依赖，分析程序就严重依赖从左往右的求值顺序
4.47
不可以，会有陷入死循环的风险，如果amb生成的是verb，进入了第二个选项，就有可能陷入死循环。
改变顺序没有用，只要那个结构还存在，就有进入死循环的风险。
4.48
(define (parse-noun-phrase)
(define (maybe-extend noun-phrase)
(amb noun-phrase
(maybe-extend (list 'noun-phrase
noun-phrase
(parse-prepositional-phrase)))))
(maybe-extend (parse-simple-noun-phrase)))
(define (parse-simple-noun-phrase)
(amb (list 'simple-noun-phrase
(parse-word articles)
(parse-word nouns))
(list 'simple-noun-phrase
(parse-word articles)
(parse-word adjectives)
(parse-word nouns))))
4.49
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_49.md
将 parse-word 和 parse 修改为
(define (amb-list lst)
(if (null? lst)
(amb)
(amb (car lst) (amb-list (cdr lst)))))
(define (append list1 list2)
(if (null? list1)
list2
(cons (car list1) (append (cdr list1) list2))))
(define (parse-word word-list)
(require (not (null? *unparsed*)))
(set! *unparsed* (cdr *unparsed*))
(let ((word (amb-list (cdr word-list))))
(set! *sentence* (append *sentence* (list word)))
(list (car word-list) word)))
(define *unparsed* '())
(define *sentence* '())
(define (parse input)
(set! *sentence* '())
(set! *unparsed* input)
(let ((sent (parse-sentence)))
(require (null? *unparsed*))
*sentence*))
添加 *sentence*，用于存放生成的句子。
调用 (parse ‘(1 2 3))，表示生成的句子含有 3 个单词，生成的前 15 个句子为：
;; (parse '(1 2 3))
(the student studies)
(the student lectures)
(the student eats)
(the student sleeps)
(the professor studies)
(the professor lectures)
(the professor eats)
(the professor sleeps)
(the cat studies)
(the cat lectures)
(the cat eats)
(the cat sleeps)
(the class studies)
(the class lectures)
(the class eats)
...
调用 (parse ‘(1 2 3 4 5 6 7 8 9)), 表示生成的句子含有 9 个单词，生成的前 15 个句子为：
;; (parse '(1 2 3 4 5 6 7 8 9))
(the student studies for the student for the student)
(the student studies for the student for the professor)
(the student studies for the student for the cat)
(the student studies for the student for the class)
(the student studies for the student for a student)
(the student studies for the student for a professor)
(the student studies for the student for a cat)
(the student studies for the student for a class)
(the student studies for the student to the student)
(the student studies for the student to the professor)
(the student studies for the student to the cat)
(the student studies for the student to the class)
(the student studies for the student to a student)
(the student studies for the student to a professor)
(the student studies for the student to a cat)
...
4.50
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_50.md
(define (insert-list lst item n)
(if (= n 0)
(cons item lst)
(cons (car lst) (insert-list (cdr lst) item (- n 1)))))
(define (shuffle lst)
(if (null? lst)
lst
(let ((n (random (length lst))))
(insert-list (shuffle (cdr lst)) (car lst) n))))
(define (ramb? exp) (tagged-list? exp 'ramb))
(define (ramb-choices exp) (shuffle (cdr exp)))
(define (analyze-ramb exp)
(let ((cprocs (map analyze (ramb-choices exp))))
(lambda (env succeed fail)
(define (try-next choices)
(if (null? choices)
(fail)
((car choices) env
succeed
(lambda ()
(try-next (cdr choices))))))
(try-next cprocs))))
练习 4.49 的代码，将 amb 修改成 ramb 后，每次执行程序，生成的句子都可能会不同。但是每次连续生成十几个句子，还是会很单调。就算修改为 ramb, 对练习 4.49 中 Alyssa 遇到的问题也没有什么帮助。
比如某一次运行，其结果为
;; ;; (parse '(1 2 3))
(a class sleeps)
(a class eats)
(a class lectures)
(a class studies)
(a cat sleeps)
(a cat eats)
(a cat lectures)
(a cat studies)
(a professor sleeps)
(a professor eats)
(a professor lectures)
(a professor studies)
(a student sleeps)
(a student eats)
(a student lectures)
...
;; (parse '(1 2 3 4 5 6 7 8 9))
(a class with a class with a class sleeps)
(a class with a class with a class eats)
(a class with a class with a class lectures)
(a class with a class with a class studies)
(a class with a class with a cat sleeps)
(a class with a class with a cat eats)
(a class with a class with a cat lectures)
(a class with a class with a cat studies)
(a class with a class with a professor sleeps)
(a class with a class with a professor eats)
(a class with a class with a professor lectures)
(a class with a class with a professor studies)
(a class with a class with a student sleeps)
(a class with a class with a student eats)
(a class with a class with a student lectures)
...
4.51
(define (analyze-permanent-set! exp)
(let ((var (assignment-variable exp))
(vproc (analyze (assignment-value exp))))
(lambda (env succeed fail)
(vproc env
(lambda (val fail2)
(set-variable-value! var val env)
(succeed 'ok fail2))
fail))))
(define (permanent-set? exp) (tagged-list? exp 'permanent-set!))
4.52
(define (if-fail? exp) (tagged-list? exp 'if-fail))
(define (analyze-if-fail exp)
(let ((first-proc (analyze (cadr exp)))
(second-proc (analyze (caddr exp))))
(lambda (env succeed fail)
(first-proc env
succeed
(lambda ()
(second-proc env succeed fail))))))
4.53
((8 35) (3 110) (3 20))
4.54
(define (analyze-require exp)
(let ((pproc (analyze (require-predicate exp))))
(lambda (env succeed fail)
(pproc env
(lambda (pred-value fail2)
(if (not (true? pred-value))
(fail2)
(succeed 'ok fail2)))
fail))))
4.55
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
(supervisor (Fect Cy D) (Bitdiddle Ben))
(supervisor (Hacker Alyssa P) (Bitdiddle Ben))
(job (Cratchet Robert) (accounting scrivener))
(job (Scrooge Eben) (accounting chief accountant))
(address (Aull DeWitt) (Slumerville (Onion Square) 5))
(address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
(address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
4.56
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_56.md
(and (supervisor ?person (Bitdiddle Ben))
(address ?person ?where))
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben))
(address (Tweakit Lem E) (Boston (Bay State Road) 22)))
(and (supervisor (Fect Cy D) (Bitdiddle Ben))
(address (Fect Cy D) (Cambridge (Ames Street) 3)))
(and (supervisor (Hacker Alyssa P) (Bitdiddle Ben))
(address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
(and (salary (Bitdiddle Ben) ?ben-salary)
(salary ?person ?person-salary)
(lisp-value < ?person-salary ?ben-salary))
(and (salary (Bitdiddle Ben) 60000) (salary (Aull DeWitt) 25000) (lisp-value < 25000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Cratchet Robert) 18000) (lisp-value < 18000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Reasoner Louis) 30000) (lisp-value < 30000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Tweakit Lem E) 25000) (lisp-value < 25000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Fect Cy D) 35000) (lisp-value < 35000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Hacker Alyssa P) 40000) (lisp-value < 40000 60000))
(and (supervisor ?person ?boss)
(not (job ?boss (computer . ?type)))
(job ?boss ?boss-job))
(and (supervisor (Aull DeWitt) (Warbucks Oliver))
(not (job (Warbucks Oliver) (computer . ?type)))
(job (Warbucks Oliver) (administration big wheel)))
(and (supervisor (Cratchet Robert) (Scrooge Eben))
(not (job (Scrooge Eben) (computer . ?type)))
(job (Scrooge Eben) (accounting chief accountant)))
(and (supervisor (Scrooge Eben) (Warbucks Oliver))
(not (job (Warbucks Oliver) (computer . ?type)))
(job (Warbucks Oliver) (administration big wheel)))
(and (supervisor (Bitdiddle Ben) (Warbucks Oliver))
(not (job (Warbucks Oliver) (computer . ?type)))
(job (Warbucks Oliver) (administration big wheel)))
4.57
(rule (can-replace ?person-1 ?person-2)
(and (job ?person-1 ?job-1)
(job ?person-2 ?job-2)
(not (same ?person-1 ?person-2))
(or (same ?job-1 ?job-2)
(can-do-job ?job-1 ?job-2))))
(can-replace ?x (Fect Cy D))
(can-replace (Hacker Alyssa P) (Fect Cy D))
(can-replace (Bitdiddle Ben) (Fect Cy D))
(and (can-replace ?person-1 ?person-2)
(salary ?person-1 ?salary-1)
(salary ?person-2 ?salary-2)
(lisp-value < ?salary-1 ?salary-2))
(and (can-replace (Fect Cy D) (Hacker Alyssa P))
(salary (Fect Cy D) 35000)
(salary (Hacker Alyssa P) 40000)
(lisp-value < 35000 40000))
(and (can-replace (Aull DeWitt) (Warbucks Oliver))
(salary (Aull DeWitt) 25000)
(salary (Warbucks Oliver) 150000)
(lisp-value < 25000 150000))
4.58
(rule (big-hand ?person ?division)
(and (job ?person (?division . ?job-type))
(or (not (supervisor ?person ?boss))
(and (supervisor ?person ?boss)
(not (job ?boss (?division . ?boss-job-type)))))))
4.59
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_59.md
a)
(meeting ?x (Friday ?t))
;查询结果
(meeting administration (Friday 1pm))
b)
(rule (meeting-time ?person ?day-and-time)
(or (meeting whole-company ?day-and-time)
(and (job ?person (?division . ?type))
(meeting ?division ?day-and-time))))
c)
(meeting-time (Hacker Alyssa P) (Wednesday ?time))
;查询结果
(meeting-time (Hacker Alyssa P) (Wednesday 4pm))
(meeting-time (Hacker Alyssa P) (Wednesday 3pm))
4.60
因为规则不涉及员工的顺序性，为了有顺序性，我们可以进行字典序排序。
(and (lives-near (?last-name-1 . ?name-1) (?last-name-2 . ?name-2))
(lisp-value
(lambda (s1 s2) (string<=? (symbol->string s1) (symbol->string s2)))
?last-name-1 ?last-name-2))
4.61
((2 3) next-to 4 in (1 (2 3) 4))
(1 next-to (2 3) in (1 (2 3) 4))
(3 next-to 1 in (2 1 3 1))
(2 next-to 1 in (2 1 3 1))
4.62
(rule (last-pair (?x) (?x)))
(rule (last-pair? (?x . ?y) ?z)
(last-pair? ?y ?z))
4.63
(rule (grandson ?G ?S)
(and (son ?G ?F)
(son ?F ?S)))
(rule (son ?man ?son)
(and (wife ?man ?woman)
(son ?woman ?son)))
4.64
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_64.md
查询(outranked-by (Bitdiddle Ben) ?who)的时候，?staff-person会约束到(Bitdiddle Ben)。?boss约束到 ?who。运行到递归规则(outranked-by ?middle-manager ?boss)时，这时 ?boss约束到 ?who, ?middle-manager没有约束，于是又会再次查询(outranked-by ?middle-manager ?who)这样再引起递归查询，不断循环，没有停止条件。
4.65
因为他的下属很多，从不同的下属查询时，就会将他输出多次
4.66
他的查询结果可能会重复，他可以像之前的amb求值器那样设计一个剔除重复的语句，比如说distinct，并可以这样使用：(distinct (wheel ?who)（加进 not/and/or中去）
4.67
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_67.md
先添加一些代码，用于记录查询历史。这里的 THE-QUERY-HISTORY 相当于全局变量。实际工程中，随便定义全局变量是不好的。这里定义全局变量，是为了改动较少。
(define THE-QUERY-HISTORY '())
;; 清空历史记录
(define (history-reset!)
(set! THE-ASSERTIONS '()))
;; 插入
(define (history-insert! query frame)
(set! THE-ASSERTIONS
(cons (cons query frame) THE-ASSERTIONS)))
;; 判断
(define (history-has? query frame)
(define (simple-instantiate query frame)
(instantiate query
frame
(lambda (v f)
(string->symbol
(string-append "?"
(if (number? (cadr v))
(string-append (symbol->string (caddr v)))
(symbol->string (cadr v))))))))
(define (same? item query frame)
(let ((i0 (simple-instantiate (car item) (cdr item)))
(i1 (simple-instantiate query frame)))
(equal? i0 i1)))
(define (iter history query frame)
(if (null? history)
#f
(if (same? (car history) query frame)
#t
(iter (cdr history) query frame))))
(iter THE-ASSERTIONS query frame))
有了上述的历史记录代码。稍微修改 query-driver-loop, simple-query。
(define (query-driver-loop)
(prompt-for-input input-prompt)
(let ((q (query-syntax-process (read))))
(history-reset!) ;; 清空历史记录
xxx))
(define (simple-query query-pattern frame-stream)
(stream-flatmap
(lambda (frame)
(if (history-has? query-pattern frame) ;; 判断是否已被查询
the-empty-stream
(begin
(history-insert! query-pattern frame) ;; 将查询插入到历史记录中
(stream-append-delayed
(find-assertions query-pattern frame)
(delay (apply-rules query-pattern frame))))))
frame-stream))
我们在历史记录中，插入 (cons query frame)对。history-has? 中遍历记录，判断是否相同。
same? 的实现中，将 (cons query frame)还原成原始的形式，方便做判断。
特别注意，我们在 instantiate 中写自己的 lambda, 并没有直接调用 contract-question-mark 函数。因为代码 apply-a-rule 会将规则的变量重命名。比如每次使用规则，变量 (? boss) 依次重命名为
(? 1 boss)
(? 2 boss)
(? 3 boss)
4.68
(rule (reverse () ()))
(rule (reverse (?x . ?y) ?z)
(and (reverse ?y ?u)
(append-to-form ?u (?x) ?z)))
4.69
(rule (end-in-grandson (grandson)))
(rule (end-in-grandson (?x . ?rest))
(end-in-grandson ?rest))
(rule ((great grandson) ?x ?y)
(and (son ?x ?z)
(grandson ?z ?y)))
(rule ((great . ?rel) ?x ?y)
(and (son ?x ?z)
(?rel ?z ?y)
(end-in-grandson ?rel)))
4.70
THE-ASSERTIONS 递归调用自身会产生一个无穷流，从而陷入死循环。
4.71
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_71.md
simple-query 和 disjoin 的情况很类似，我们用 simple-query 为例。原始的 simple-query 会将流除了 car 的部分都会延迟求值。但修改后
(define (simple-query query-pattern frame-stream)
(stream-flatmap
(lambda (frame)
(stream-append
(find-assertions query-pattern frame)
(apply-rules query-pattern frame))) ;; apply-rules 会被求值，原来是延迟求值的
frame-stream))
这时 apply-rules 会立即被求值。有时 apply-rules 的求值结果是浪费的，有时也会产生额外的问题。
a)如 P322 的无穷循环规则
(assert! (married Minnie Mickey))
(assert! (rule (married ?x ?y)
(married ?y ?x)))
(married Mickey ?who)
在原始的实现中，会无穷循环。但因为 apply-rules 被延迟，simple-query 会返回。最起码会显示出结果，虽然结果是无穷流
(married Mickey Minnie)
(married Mickey Minnie)
(married Mickey Minnie)
....
但修改后的代码，会一直在 simple-query 中死循环。什么都没有显示。打印无穷流最起码会比卡住没有反应要好。
再如 not 语句查询
(assert! (married Minnie Mickey))
(assert! (rule (married ?x ?y)
(married ?y ?x)))
(not (married Mickey ?who))
(married Mickey ?who) 返回无穷流，因而 not 可以立即返回(无穷流也是有值），查询结果为
(not (married Mickey ?who))
但假如去掉 delay, 上述的查询语句会在 simple-query 中死循环。
b)disjoin中使用 delay的理由跟 simple-query 类似。假如查询
(or P1 P2)
(not (or P1 P2))
其中 P2 返回无穷流。
去掉 delay, P2 的结果没有延迟求值，出现的问题跟 simple-query 类似。
4.72
如果先遍历的第一个为无限流，就卡在第一个流里了，所以要交错合并
4.73
是立即求值，没有起到延迟求值的效果，而且又递归调用自身，所以要是遇到无限流，就陷入了死循环。
4.74
(define (simple-stream-flatmap proc s)
(simple-flatten (stream-map proc s)))
(define (simple-flatten stream)
(stream-map stream-car
(stream-filter (lambda (s) (not (stream-null? s)))
stream)))
只要传入空流和单元素流，查询系统的行为就不会改变。空流和单元素流不需要交错合并
4.75
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_75.md
(define (uniquely-asserted operands frame-stream)
(define (stream-unique? s)
(and (not (stream-null? s))
(stream-null? (stream-cdr s))))
(stream-flatmap
(lambda (frame)
(let ((s (qeval (car operands) (singleton-stream frame))))
(if (stream-unique? s)
s
the-empty-stream)))
frame-stream))
这里中文翻译错了，原文为
Test your implementation by forming a query that lists all people who supervise precisely one person.
意思是：找出所有的上级，他们只管理唯一的员工。也就是上级，底下只有一个员工。
(and (supervisor ?x ?boss)
(unique (supervisor ?anyone ?boss)))
查询结果为：
(and (supervisor (Cratchet Robert) (Scrooge Eben))
(unique (supervisor (Cratchet Robert) (Scrooge Eben))))
(and (supervisor (Reasoner Louis) (Hacker Alyssa P))
(unique (supervisor (Reasoner Louis) (Hacker Alyssa P))))
4.76
(define (new-conjoin conjuncts frame-stream)
(if (empty-conjunction? conjuncts)
frame-stream
(merge-streams
(qeval (first-conjunct conjuncts) frame-stream)
(new-conjoin (rest-conjuncts conjuncts) frame-stream))))
(define (merge-streams stream1 stream2)
(stream-flatmap (lambda (f1)
(stream-filter
(lambda (f) (not (eq? f 'failed)))
(stream-map
(lambda (f2) (merge-frames f1 f2))
stream2)))
stream1))
(define (merge-frames frame1 frame2)
(cond ((null? frame1) frame2)
((eq? 'failed frame2) 'failed)
(else
(let ((var (binding-variable (car frame1)))
(val (binding-value (car frame1))))
(let ((extension (extend-if-possible var val frame2)))
(merge-frames (cdr frame1) extension))))))
4.77
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_77.md
(define (conjoin conjuncts frame-stream)
(conjoin-mix conjuncts '() frame-stream))
(define (conjoin-mix conjs delayed-conjs frame-stream)
(if (empty-conjunction? conjs)
frame-stream
(let ((first (first-conjunct conjs))
(rest (rest-conjuncts conjs)))
(cond ((and (filter-exp? first) (has-unbound-var? first frame-stream))
(conjoin-mix rest (cons first delayed-conjs) frame-stream))
((and (filter-exp? first) (not (has-unbound-var? first frame-stream)))
(conjoin-mix rest delayed-conjs (qeval first frame-stream)))
(else
(conjoin-delayed rest delayed-conjs (qeval first frame-stream)))))))
(define (conjoin-delayed conjs delayed-conjs frame-stream)
(define (iter lst delayed-conjs frame-stream)
(if (null? lst)
(conjoin-mix conjs delayed-conjs frame-stream)
(let ((first (car lst)))
(if (has-unbound-var? first frame-stream)
(iter (cdr lst) (cons first delayed-conjs) frame-stream)
(iter (cdr lst) delayed-conjs (qeval first frame-stream))))))
(iter delayed-conjs '() frame-stream))
(define (filter-exp? exp)
(or (eq? (type exp) 'lisp-value)
(eq? (type exp) 'not)))
(define (has-unbound-var-frame? exp frame)
(define (tree-walk exp)
(cond ((var? exp)
(let ((binding (binding-in-frame exp frame)))
(if binding
(tree-walk (binding-value binding))
true)))
((pair? exp)
(or (tree-walk (car exp)) (tree-walk (cdr exp))))
(else false)))
(tree-walk exp))
(define (has-unbound-var? exp frame-stream)
(has-unbound-var-frame? exp (stream-car frame-stream)))
4.78
https://github.com/hjcapple/reading-sicp/blob/master/chapter_4/exercise_4_78.md
修改了 query-driver-loop 循环，支持 try-again。也需要修改 qeval，在 analyze 分派各个语法。
用非确定性写法，替代了原来的流式写法。原来的一系列流操作，都可去掉
(define (query-driver-loop)
(define (internal-loop try-again)
(prompt-for-input ";;; Query input:")
(let* ((input (read))
(q (query-syntax-process input)))
(cond ((eq? q 'try-again) (try-again))
((assertion-to-be-added? q)
(add-rule-or-assertion! (add-assertion-body q))
(newline)
(display "Assertion added to data base.")
(query-driver-loop))
(else
(newline)
(display ";;; Starting a new query ")
(qeval q
'()
(lambda (frame next-alternative)
(display-line ";;; Query results:")
(display-line (instantiate q
frame
(lambda (v f)
(contract-question-mark v))))
(internal-loop next-alternative))
(lambda ()
(display-line ";;; There are no more values of")
(display-line input)
(query-driver-loop)))))))
(internal-loop (lambda ()
(newline)
(display ";;; There is no current query")
(query-driver-loop))))
(define (qeval query frame succeed fail)
((analyze query frame) succeed fail))
(define (analyze exp frame)
(cond ((tagged-list? exp 'and) (conjoin (contents exp) frame))
((tagged-list? exp 'lisp-value) (lisp-value (contents exp) frame))
((tagged-list? exp 'not) (negate (contents exp) frame))
((tagged-list? exp 'or) (disjoin (contents exp) frame))
((tagged-list? exp 'always-true) (always-true (contents exp) frame))
(else (simple-query exp frame))))
4.79
pass