Section 4.3.3

当初上数分课，傅里叶级数把我们搞的欲仙欲死，过后到了常微分方程，课上老韩笑着说到了轻松的部分了，就像他爬泰山时候那个“快活三里”。这小节这几个小题是为了巩固amb-eval基础的，4.3整节的最后出现，实在有点“快活三里”的感觉。

4.50
主要不同之处就是amb中的序列是从左到右依次抽取，用的是car cdr，而这里用的是random-choose。
(define (analyze-ramb exp)
  (let ((cprocs (map analyze (amb-choices exp))))
    (lambda (env succeed fail)
      (define (try-next choices)
        (if (null? choices)
            (fail)
            (let ((random-pick (random-choose choices)))
              (let ((the-right-one (car random-pick))
                    (rest-ones (cdr random-pick)))
                (the-right-one env
                               succeed
                               (lambda() (try-next rest-ones)))))))
        (try-next cprocs))))

random-choose参数为一个list，结果是一个序对，car为抽取的元素，cdr为其余的。       
(define (random-choose seq)
  (define (random-integer-between low high)
    (+ low (random (+ (- high low) 1))))
  (let ((ref (random-integer-between 1 (length seq))))
    (define (foo k items)
      (if (= k 1)
          items
          (let ((foo-next (foo (- k 1) (cdr items))))
            (cons (car foo-next)
                  (cons (car items) (cdr foo-next))))))
    (foo ref seq)))
   
应用ramb去实现ex 4.49中的语句生成：
把里面所有的amb全部改为ramb就可以了，这样执行(parse '())就可以生成句子，不过有时动不动就出现几万、几十万字的句子……

为了控制一下句子的长度，便增加了两个全局变量verb-layer和noun-layer，利用它们控制动词短语和名词短语的层数。
(define verb-layer 0)
(define noun-layer 0)
然后在parse-verb-phrase和parse-noun-phrase中控制：
(define (parse-verb-phrase)
  (define (maybe-extend verb-phrase)
    (require (< verb-layer 3))
    (ramb verb-phrase
          (begin (set! verb-layer (+ 1 verb-layer))
                 (maybe-extend (list 'verb-phrase
                                     verb-phrase
                                     (parse-prepositional-phrase))))))
  (maybe-extend (parse-word verbs)))
(define (parse-noun-phrase)
  (define (maybe-extend noun-phrase)
    (require (< noun-layer 3))
    (ramb noun-phrase
          (begin (set! noun-layer (+ 1 noun-layer))
                 (maybe-extend (list 'noun-phrase
                                     noun-phrase
                                     (parse-prepositional-phrase))))))
  (maybe-extend (parse-simple-noun-phrase)))

每次分析开始都要清0，以便重新构造。
(define (parse-sentence)
  (set! verb-layer 0)
  (set! noun-layer 0)
  (list 'sentence (parse-noun-phrase) (parse-verb-phrase)))

这样，运行(parse '())就可以生成不太长的句子了，而且不断的try-again可以遍历它们！可惜速度有些慢。


ps. 做这题的时候出了点小毛病：开始做的时候random-integer-between中的random部分我没+1，结果代价就是(random-integer-between 1 2)只会出现1.。这一小错不要紧，导致后面的an-element-of只是顺序取值。我当时还是没发现病因，就胡乱猜测ramb不能用an-element-of这种递归形式，而只能用(ramb 1 2 3 4 5)这种（当时竟然没发现这个式子从来第一次没出现过5）。然后又用宏实现了一个amb-eval中类似scheme中的apply过程，这样就可以把多个参数作为一个列表传过来……前后折腾了两个多小时，才走上正道。

4.51
比原来的set!要简单，就是去掉消除副作用的部分就行了。
(define (analyze-permanent-assignment 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))))
             
4.52
只要看出aproc应该在cproc的fail部分被调用就明白了。
(define (analyze-if-fail exp)
  (let ((cproc (analyze (if-fail-consequent exp)))
        (aproc (analyze (if-fail-alternative exp))))
    (lambda (env succeed fail)
      (cproc env
             succeed
             (lambda ()
               (aproc env succeed fail))))))
(define (if-fail-consequent exp) (cadr exp))
(define (if-fail-alternative exp) (caddr exp))

4.53             
生成和为素数的序对，就和当初的map-filter一样。
((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-val fail2)
               (if (false? pred-val)
                   (fail2)
                   (succeed 'ok fail2)))
             fail))))

Section 4.3.2
4.38
此处中译版出错：原文"Modify the multiple-dwelling procedure to omit the requirement that Smith and
Fletcher do not live on adjacent floors."  翻译"增加斯迈尔和弗莱舍不住相邻层的要求。" 把omit翻译成了"增加"。
题目答案明显：去掉(require (not (= (abs (- fletcher smith)) 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
有关系。题目中一共会通过一系列require检测5^5种情况。改变require语句的顺序就可以调节每次检测的速度，也就是把限制性强、检测起来快的原则放在前面，其余放在后面。比如(require (distinct? (list baker cooper fletcher miller smith)))这条语句就应该放在后面。

通过实验验证：把current-inexact-milliseconds放入求解过程中，用来观测运行时间。
(define (multiple-dwelling)
  (let ((former-time (current-inexact-milliseconds))
        (baker (amb 1 2 3 4 5))
        (cooper (amb 1 2 3 4 5))
        (fletcher (amb 1 2 3 4 5))
        (miller (amb 1 2 3 4 5))
        (smith (amb 1 2 3 4 5)))
    (require (not (= fletcher 5)))
    (require (not (= fletcher 1)))
    (require (not (= baker 5)))
    (require (not (= cooper 1)))
    (require (> miller cooper))
    (require (not (= (abs (- smith fletcher)) 1)))
    (require (not (= (abs (- fletcher cooper)) 1)))
    (require (distinct? (list baker cooper fletcher miller smith)))
    (display (- (current-inexact-milliseconds) former-time))
    (list (list 'baker baker)
          (list 'cooper cooper)
          (list 'fletcher fletcher)
          (list 'miller miller)
          (list 'smith smith))))
结果：
;;;Starting a new problem 360.0
;;;Amb-Eval value:
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
而原过程所需时间为500左右，猜测正确。

4.40         
(define (multiple-dwelling)
  (let ((former-time (current-inexact-milliseconds))
        (baker (amb 1 2 3 4 5)))
    (require (not (= baker 5)))
    (let ((cooper (amb 1 2 3 4 5)))
      (require (not (= cooper 1)))
      (let ((fletcher (amb 1 2 3 4 5)))
        (require (not (= fletcher 5)))
        (require (not (= fletcher 1)))
        (require (not (= (abs (- fletcher cooper)) 1)))
        (let ((miller (amb 1 2 3 4 5)))
          (require (> miller cooper))
          (let ((smith (amb 1 2 3 4 5)))
            (require (not (= (abs (- smith fletcher)) 1)))
            (require (distinct? (list baker cooper fletcher miller smith)))
            (display (- (current-inexact-milliseconds) former-time))
            (list (list 'baker baker)
                  (list 'cooper cooper)
                  (list 'fletcher fletcher)
                  (list 'miller miller)
                  (list 'smith smith))))))))
这就和我们做题的思路比较像了——用判断条件直接排除掉一系列情况，而不是把所有情况列举出来一个个筛选。
效果也是很明显，47.0，比上一题中的360.0快了不少。

4.41
用的是第二章的那种map--filter方法：
(define (situ n)
  (if (= n 1)
      (map list '(1 2 3 4 5))
      (flat-map (lambda (x)
                  (map (lambda(xx) (cons x xx)) (situ (- n 1))))
                '(1 2 3 4 5))))
(filter (lambda (x)
          (let ((baker (car x))
                (cooper (cadr x))
                (fletcher (caddr x))
                (miller (cadddr x))
                (smith (car (cddddr x))))
            (and (not (= baker 5))
                 (not (= cooper 1))
                 (not (= fletcher 1))
                 (not (= fletcher 5))
                 (> miller cooper)
                 (not (= (abs (- smith fletcher)) 1))
                 (not (= (abs (- fletcher cooper)) 1))
                 (distinct? x))))
        (situ 5))
结果：((3 2 4 5 1))

4.42
所谓一句真话一句假话，可以看做是两个条件异或求值为真。由于这道题存在异或关系的判断，所以还需要给求值器加入and or这两个special-form。
;;======and  or=======
(define (analyze-and exp)
  (define (helper clauses)
    (if (null? clauses)
        (lambda(env succeed fail)
          (succeed true fail))
        (lambda (env succeed fail)
          ((analyze (car clauses)) env
                                   (lambda (val fail2)
                                     (if (false? val)
                                         (succeed false fail2)
                                         ((helper (cdr clauses)) env succeed fail2)))
                                   fail))))
  (helper (cdr exp)))
(define (analyze-or exp)
  (define (helper clauses)
    (if (null? clauses)
        (lambda(env succeed fail)
          (succeed false fail))
        (lambda (env succeed fail)
          ((analyze (car clauses)) env
                                   (lambda (val fail2)
                                     (if (true? val)
                                         (succeed true fail2)
                                         ((helper (cdr clauses)) env succeed fail2)))
                                   fail))))
  (helper (cdr exp)))

这样就可以定义异或关系，通过和例子中相同的方法解答：
(define (xor p1 p2)
  (or (and p1 (not p2))
      (and (not p1) p2)))
(define (liars)
  (let ((betty (amb 1 2 3 4 5))
        (ethel (amb 1 2 3 4 5))
        (joan (amb 1 2 3 4 5))
        (kitty (amb 1 2 3 4 5))
        (mary (amb 1 2 3 4 5)))
    (require (xor (= kitty 2) (= betty 3)))
    (require (xor (= ethel 1) (= joan 2)))
    (require (xor (= joan 3) (= ethel 5)))
    (require (xor (= kitty 2) (= mary 4)))
    (require (xor (= mary 4) (= betty 1)))
    (require (distinct? (list betty ethel joan kitty mary)))
    (list (list 'betty betty)
          (list 'ethel ethel)
          (list 'joan joan)
          (list 'kitty kitty)
          (list 'mary mary))))
最后得到唯一解：((betty 3) (ethel 5) (joan 2) (kitty 1) (mary 4))

4.43
这题比较复杂。那个multiple-dwelling问题只有一组关系：人和楼层。这里有两组关系：女儿与父亲，女儿名字与游艇所有者。这里我取的是女儿&游艇名字作为amb的对象，我感觉用父亲的名字也可以(父亲的女儿&父亲的游艇)。所以本题中某人，比如Ann，其值是一个list，(car Ann)为Ann的父亲，(cadr Ann)为游艇Ann的主人。为了方便，自己用数字给这5个父亲打标((Moore Downing Hall SB.Hood Parker) is (1 2 3 4 5))。
程序如下（好长）：
(define (girls-and-yachts)
  (define (father-of girl)  (car girl))
  (define (owner-of-the-yacht girl-name) (cadr girl-name))
  (let ((Ann (list (amb 1 2 3 4 5) (amb 1 2 3 4 5))))
    (require (distinct? (list (father-of Ann) (owner-of-the-yacht Ann))))
    (require (= (father-of Ann) 1))
    (let ((Gabrielle (list (amb 1 2 3 4 5) (amb 1 2 3 4 5))))
      (require (distinct? (list (father-of Gabrielle) (owner-of-the-yacht Gabrielle))))
      (require (= (owner-of-the-yacht Gabrielle) 4))
      (let ((Lorna (list (amb 1 2 3 4 5) (amb 1 2 3 4 5))))
        (require (distinct? (list (father-of Lorna) (owner-of-the-yacht Lorna))))
        (require (= (owner-of-the-yacht Lorna) 1))
        (let ((Rosalind (list (amb 1 2 3 4 5) (amb 1 2 3 4 5))))
          (require (distinct? (list (father-of Rosalind) (owner-of-the-yacht Rosalind))))
          (require (= (owner-of-the-yacht Rosalind) 3))
          (let ((Melissa (list (amb 1 2 3 4 5) (amb 1 2 3 4 5))))
            (require (distinct? (list (father-of Melissa) (owner-of-the-yacht Melissa))))
            (require (= (owner-of-the-yacht Melissa) 2))
            (require (= (father-of Melissa) 4))
            (let ((girls (list Ann Gabrielle Lorna Rosalind Melissa)))
              (define (whose-father-is x girl-list)
                (cond ((null? girl-list) (list 0 0))
                      ((= (father-of (car girl-list)) x) (car girl-list))
                      (else (whose-father-is x (cdr girl-list)))))
              (require (= (father-of Gabrielle) (owner-of-the-yacht (whose-father-is 5 girls))))
              (let ((the-fathers (map father-of girls))
                    (the-owners (map owner-of-the-yacht girls)))
                (require (distinct? the-fathers))
                (require (distinct? the-owners))
                (list (list 'Ann Ann)
                      (list 'Gabrielle Gabrielle)
                      (list 'Lorna Lorna)
                      (list 'Rosalind Rosalind)
                      (list 'Melissa Melissa))))))))))
稍微绕了个弯的地方是最后一个条件"Gabrielle的父亲的游艇取的是Dr.Parker女儿的名字"，需要寻找"Dr.Parker的女儿"。

结果为((Ann (1 5)) (Gabrielle (3 4)) (Lorna (2 1)) (Rosalind (5 3)) (Melissa (4 2)))，也就是说Lorna的父亲是Colonel Downing。

如果去掉Ann姓Moore这个条件，也就是去掉(require (= (father-of Ann) 1))，会有两个结果：
((Ann (1 5)) (Gabrielle (3 4)) (Lorna (2 1)) (Rosalind (5 3)) (Melissa (4 2)))
((Ann (3 5)) (Gabrielle (1 4)) (Lorna (5 1)) (Rosalind (2 3)) (Melissa (4 2)))

4.44
记得视频中提到流的概念的时候举过八皇后的例子，说有两种策略，一是像构造一颗树那样一个一个的添加皇后，遇到错误后回溯；另一个就是把所有的可能都列举出来，然后筛选。当时采用的是流的方法，构造简单而且由于memo-proc的存在，使得速度上也不错。这次八皇后的解法使用了amb-eval的回溯机制，整个过程看起来更简单了。这个amb-eval写得实在是很巧妙……我只到了理解"鱼"的层次，离怎样想出amb-eval实现的方法这个"渔"的境界还很远。
(define (queens board-size)
  (define (safe? q position)
    (if (null? position)
        true
        (let ((old-queen (car position)))
          (and (not (= old-queen q))
               (not (= (abs (- old-queen q)) (length position)))
               (safe? q (cdr position))))))
  (define (adjoin-new-queen new-queen position)
    (append position (list new-queen)))
  (define (queen-cols q-ref)
    (if (= q-ref 0)
        '()
        (let ((old-position (queen-cols (- q-ref 1))))
          (let ((n-q (an-integer-between 1 board-size)))
            (require (safe? n-q old-position))
            (adjoin-new-queen n-q old-position)))))
  (queen-cols board-size))
 
 这里同样有当初ex 2.43中的那个关于效率的微妙问题：
 如果把queen-cols写成这样：
 (define (queen-cols q-ref)
    (if (= q-ref 0)
        '()
        (let ((n-q (an-integer-between 1 board-size)))
          (let ((old-position (queen-cols (- q-ref 1))))
            (require (safe? n-q old-position))
            (adjoin-new-queen n-q old-position)))))
那么就得到了当初Louis Reasoner的奇慢的程序。原因也差不多: 起回溯作用的语句是an-integer-between，而回溯的时候是没必要每次都再求一遍old-position的。


4.45
这题轻松一下，玩玩小时候拼词组句的小游戏。
5个结果，搭配本人中文自然语言译本：
;;教授教学生，教授在教室里，教授带着猫
(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)))))
;;教授教学生，教授在教室里，教室带着猫
(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)))))))
;;教授教学生，学生在教室里，教授带着猫
(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)))))
;;教授教学生，学生在教室里，学生带着猫
(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)))))))
;;教授教学生，学生在教室里，教室带着猫
(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)))))))))

4.46
举例比如：
(define (parse-simple-noun-phrase)
  (list 'simple-noun-phrase
        (parse-word articles)
        (parse-word nouns)))
如果amb求值顺序为从右至左，那么对于'(a cat)就会先去用名词匹配a，造成混乱。

4.47
想法是正确的，有时也能得出正确结果，但有时也会出现问题：
比如(parse '(the cat eats in the class))，第一次结果正确，但是当try-again时发生死循环。
如果(parse '(the cat haha))，问题就更突出些：新的parse-noun-phrase是个死胡同，一旦进去就再不会出来，即使发生明显的不匹配也不会出来。

观察parse-word过程:
(define (parse-word word-list)
  (require (not (null? *unparsed*)))
  (require (memq (car *unparsed*) (cdr word-list)))
  (let ((found-word (car *unparsed*)))
    (set! *unparsed* (cdr *unparsed*))
    (list (car word-list) found-word)))

起判断匹配与否的语句是(require (memq (car *unparsed*) (cdr word-list)))，这样比如一个需要名词的地方出现了nouns里面没有的"haha"，那么就会运行(amb)。

看一下本来的parse-verb-phrase：
(define (parse-verb-phrase)
  (define (maybe-extend verb-phrase)
    (amb verb-phrase
         (maybe-extend (list 'verb-phrase
                             verb-phrase
                             (parse-prepositional-phrase)))))
  (maybe-extend (parse-word verbs)))
这里有否介词短语两种情况会调用parse-word来判断匹配情况，因为无论哪种情况首个单词都应该是动词，遇到"haha"都应该报错。

再看下Louis Reasoner同学的：
(define (parse-verb-phrase)
  (amb (parse-word verbs)
       (list 'verb-phrase
             (parse-verb-phrase)
             (parse-prepositional-phrase))))
看到了吧，这里parse-word是"可选的"，所以遇到了"haha"就绕开，而后递归调用(parse-verb-phrase)再绕……程序就死掉了。


4.48
偷懒写个最简单的形容词部分：
(define adjectives '(adj blue angry nice))
(define (parse-simple-noun-phrase)
  (amb (list 'simple-noun-phrase
             (parse-word articles)
             (parse-word adjectives)
             (parse-word nouns))
       (list 'simple-noun-phrase
             (parse-word articles)
             (parse-word nouns))))
测试：
;;;Amb-Eval input:
(parse '(the angry cat eats in the blue class))

;;;Starting a new problem
;;;Amb-Eval value:
(sentence (simple-noun-phrase (article the) (adjs angry) (noun cat))
          (verb-phrase (verb eats)
                       (prep-phrase (prep in)
                                    (simple-noun-phrase (article the)
                                                        (adjs blue)
                                                        (noun class)))))
                                                       
4.49
简单的修改：
(define (parse-word word-list)
  (let ((new-word (an-element-of (cdr word-list))))
    (list (car word-list) new-word)))
结果：      
the blue student studies
the blue student studies for the blue student
the blue student studies for the blue student for the blue student
...看来没有random-amb这东西真是不好玩                                                       

Section 4.3.1

由于前两小节的习题需要amb-evaluator去测试，所以需要先把4.3.3中的求值器实现。

amb-eval相比之前两个求值器要复杂，郁闷的看了n遍。其中比较麻烦的事情就是succeed和fail过程传来传去，还有succeed的调用也让人一上来觉得不太适应。

所谓的succeed和fail，可以理解为运行过程中的两个分叉，之前接触的eval-apply循环、lazy-eval可以看做是全程succeed的情况。相类似的analyze-self-evaluating/analyze-quoted等过程，都只是传递succeed和fail过程而涉及不到运行的分叉。

处理if语句时，由于if-predict中可能有amb语句(可以造成fail)，所以要进行判断：如果if-predict是"成功的"，那么分情况考虑if-consequent或者if-alternative；若是"失败"的，就调用fail过程。书中analyze-if中的fail2只是为了在名字上与fail区分开来，实际的值也是fail，而不会存在两个不同的fail过程。

set!过程又与上面不同，由于需要消除赋值带来的副作用，所以求值assignment-value的fail过程和外层set!的fail过程是不同的，不可以像if那样直接调用过来。

个人感觉最难理解的是过程应用中的get-args过程。它的作用大概就是把apply的参数值提取出来(由于这些值都是(lambda(env succeed fail)(...)之类的东西，所以需要另写get-args而不是直接用map))。其中递归调用get-args时，增量是get-args的参数succeed的val部分。可以这么看: succeed过程实际是(lambda(args fail) (succeed args fail))，仔细观察程序可以发现，递归调用中的succeed部分是这样的：(lambda(args fail) (succeed (cons arg args) fail))，增加的那个arg就是提取出来的value。

相关的analyze-application和execute-application相对容易，理解这部分可以通过人肉追踪一个简单的过程应用来完成。比如(+ 1 (amb 2 3))。 (ps. 这里如果用Drscheme的调试功能会比较郁闷，因为绝大多数想知道的数据和过程都是(#procedure)...)
接下来的amb过程是整个求值器中最独特最独特的部分，但是原理并不复杂，有点类似analyze-sequence。

4.35
(define (an-integer-between low high)
  (if (> low high)
      (amb)
      (amb low (an-integer-between (+ 1 low)
                                   high))))

4.36
按照题中的顺序，如果只用an-integer-starting-from简单代替的话，程序会取i=1, j=1，然后把k从1一直取值试下去。得不到正确结果。
所以这里需要的是一种能够遍历i、j、k的方法，有点类似第三章讲流时的那个求所有整数序对的意思，不过这里更简单一些。
(define (a-pythagorean-triple)
  (let ((k (an-integer-start-from 1)))
    (let ((i (an-integer-between 1 k)))
      (let ((j (an-integer-between i k)))
        (require (= (+ (* i i) (* j j)) (* k k)))
        (list i j k)))))

4.37
没做实验，想来应该是快些的，避免了很多无效的列举。虽然增加了求平方根操作，不过相比较那些无效的ijk的运算也应该算是值得了。

1. 书上提到Y combinator是在Ex 4.21中，用来实现一些不用函数名称的递归方法。
这里！有一个构造Y的过程，最后可以以一个单个参数的过程为参数(比如阶乘，fibnacci不行)，得到一个不用函数名来实现递归的过程。
其中分了6个step，个人感觉Step2--6都是中规中距的做一些文字游戏，而Step1做的工作是创造性的(也就是书中4.21给出的例子)。
Step1 中构造了一个fact-maker：
  (define fact-maker
    (lambda (procedure)
      (lambda (n)
         (if (zero? n)
             1
             (* n ((procedure procedure) (- n 1)))))))
然后通过(fact-maker fact-maker)来成功构造fact过程。

而后面的工作就是抽象、组合，最后形成一个有一般意义的Y combinator，不过只能形成单个参数的过程。
(define Y
  (lambda(X)
    ((lambda(proc)
       (X (lambda(arg) ((proc proc) arg))))
     (lambda(proc)
       (X (lambda(arg) ((proc proc) arg)))))))



2. 视频Lecture-7a中也提到Y combinator，是在讲到求不动点的策略的时候，仿佛这个Y除了完成一些上述的小技巧之外，还有些更深层次的东西。
这里的不动点，不是狭义的指一个数值，它还包括函数过程。比如factorial过程就是
(lambda (proc)
  (lambda (n)
    (if (zero? n)
        1
        (* n (proc (- n 1))))))
的fixed-point。而这里求fixed-point的方法就是无限的迭代执行，就像拿起计算器随便取一个值然后狂按cos，最后得到0.73左右的一个数。这种方法可能得到正确结果，也可能得不到，结果取决与具体问题，就像线性方程组的解的情况（唯一/无限多个/无解）。而其原理的证明据说很复杂。
所以我们需要构造一个过程，使其能表达出无限的迭代。
(define Y
  (lambda(f)
    ((lambda(x) (f (x x)))
     (lambda(x) (f (x x))))))
这样定义Y就可以得到(Y F)=(F (Y F))的效果，从而产生(F (F (F...)))这一无限序列。
这里的Y比前面定义的要简洁一些，但是我不知道这样的Y在scheme中怎样与一个具体过程结合形成一个可以正常运行的过程。


实际工程实现中貌似是不会用Y来实现递归的，因为程序需要调试，需要交互。不过好像在lambda演算中意义不小。

Section 4.2.1
4.25
用非特殊形式的unless计算factorial会出现死循环，这是由于(factorial n)会不断的计算(factorial (- n 1))、(factorial (- (- n 1) 1))...而在此之前不会考虑过程体里面的if过程。
在正则序语言中可以。其实所谓正则序语言，并不是全部过程都不优先对参数求值(那样就永远得不到结果了...)，也是要有一些严格的基本过程做基础如if/cond等。这样在调用unless时对condition/usual-value/exception-value都会延迟求值，直到(= n 1)的判断时才会对n求值进而做判断是要执行usual-value还是exception-value。这样(factorial n)就能正常工作了。

4.26
实现：
(define (eval-unless exp env)
  (eval (make-if (unless-pred exp) (unless-exception exp) (unless-usual exp)) env))
(define (unless-pred exp) (cadr exp))
(define (unless-exception exp) (cadddr exp))
(define (unless-usual exp) (caddr exp))
然后加入安装包(put 'eval 'unless eval-unless)

但是如此生成为特殊形式，在环境中是不会有unless这个变量的。
比如定义这个过程，定义一个unless过程就是必要的：
(define (if-or-unless operator pred consequent alternative)
  (operator pred consequent alternative))
这里operator可以取if或者unless(可能把if生成表达式也是件麻烦事)。

Section 4.2.2
4.27
;;; L-Eval input:
count

;;; L-Eval output:
1

;;; L-Eval input:
w

;;; L-Eval output:
10

;;; L-Eval input:
count

;;; L-Eval output:
2
与应用序不同之处在(define w (id (id 10)))之后，count变为1而不是2. 原因是只有外层的id被执行了，而内层的id被延迟到求w时才得到执行。如果用带有记忆功能的force-it，以后再求值w时count不会变，否则每次count加1.

4.28
两者的不同之处就在于操作符的求值，所以找个操作符需要求值的例子：
(define (foo x) x)
((foo +) 10 20)
如果按照题中的做法，用eval而不是actual-value求(foo +)的值，会得到一个以'thunk开始的list，而不是(primitive +)，结果就是使apply报错。

4.29
主要不同体现在执行完(square (id 10))后count的值上。
有记忆功能的force-it会显示1，否则是2.

开始对这个save功能有些误解，以为可以实现类似ex 3.27中memorize的功能，使得诸如(fib 10)的求值过程在不同的调用中只执行一次。后来发现错了，这里的记忆功能只限于某个过程之内，只有当其参数被求值不止一次时，速度优势才会显现出来。
比如factorial：
(define (fact n)
  (if (= n 1)
      1
      (* n (- n 1))))
这里之所以能提高效率，是因为过程中对n的调用有3次。这样没有记忆功能的force-it就会对('thunk n)进行三次eval的求值，而有记忆功能的force-it只执行一次，之后两次就是简单的取thunk-value即可。

4.30
a) 争议部分在于(proc (car items))这一句，如果它得不到执行，那么就是Ben理解的Cy的意思；反之则是Ben反驳Cy的观点。跟踪一下for-each的执行过程可以发现，在这句执行时，其环境中proc的值应该是('thunk (lambda(x) (newline) (display x)) <env>)。通过eval对application部分的实现可知，这里proc作为操作符是要经过actual-value后才传给apply，所以此句可以执行并且得到执行。

b) 用原来的eval-sequence，(p1 1)和(p2 1)分别返回(1 2)和1。 (p1 1)返回(1 2)的原因与for-each类似，而(p2 1)中赋值语句没有得到执行的原因是(set! x (cons x '(2)))被放在了参数的位置上，而不是像proc那样放在操作数的位置上——参数是会被延迟求值的，又因为eval-sequence中对每个过程使用eval而不是actual-value求值，这里(eval e env)的结果是('thunk (set! x (cons x '(2))) <env>)。
如果应用的Cy的建议，那么两者都会返回(1 2)。对于(p2 1)，与原来不同的是eval-sequence对每个过程用了actual-value。那么执行到e时，实际的求值语句是(force-it (eval e env))，也就是对('thunk (set! x (cons x '(2))) <env>)进行了force-it操作。

c) 因为force-it语句中对参数是否为thunk有判断，对于没有thunk标签的过程也可以得到正确执行。

d) 个人感觉Cy的更好一些。首先Cy的过程没有违反惰性求值的要求——对象只有在需要时才求值，而且改正了原过程在某些情况下会犯的错误。比如(p2 1)，其中e在被需要时得到求值，但是我们并不希望某个变量求值以后得到的结果会是带有thunk头的这种内部形式，这样来看，原过程实际上可以认为是有错误的。

4.31
正则序和应用序在本章实现的解释器上主要区别就在与apply中一般过程(compound-procedure)中参数部分的处理：是list-of-true-value还是list-of-delayed-value。本题把这种不同变得更加一般化，那就是使一列参数中的不同个体可以用不同策略，而不是全部actual-value或者delay。
所以，我们只要控制不同的参数加入环境中的值即可，再由force-it根据环境中的值来决定采取何种策略来返回。
我通过(helper hvars hvals env)过程读入形参和实参，经过判断、求值返回一个序对，car和cdr就是可以直接加入环境的值。
;-----apply-helper-------
(define (helper hvars hvals env)
  (if (= (length hvars) (length hvals))
      (let ((new-vars (map (lambda (var)
                             (cond ((lazy-memo? var) (car var))
                                   ((lazy? var) (car var))
                                   ((not (pair? var)) var)
                                   (else (error "Wrong parameter " var))))
                           hvars))
            (new-vals (map (lambda(var val)
                             (cond ((lazy-memo? var) (delay-it-memo val env))
                                   ((lazy? var) (delay-it val env))
                                   (else (actual-value val env))))
                           hvars
                           hvals)))
        (cons new-vars new-vals))
      (if (< (length hvars) (length hvals))
          (error "Too Many vals" hvars hvals)
          (error "Too Few vals" hvars hvals))))
(define (lazy-memo? var)
  (and (pair? var) (eq? (cadr var) 'lazy-memo)))
(define (lazy? var)
  (and (pair? var) (eq? (cadr var) 'lazy)))         
这样可以把apply修改为:         
(define (apply procedure args env)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure
                                    (list-of-true-value args env)))
        ((compound-procedure? procedure)
         (let ((env-result (helper (procedure-parameters procedure) args env)))
             (eval-sequence
              (procedure-body procedure)
              (extend-environment
               (car env-result)
               (cdr env-result)
               (procedure-environment procedure)))))
        (else (error "Unknown procedure type--APPLY" procedure))))
稍微修改一下force-it:
(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)
           (set-cdr! (cdr obj) '())
           result))
        ((evaluated-thunk? obj) (thunk-value obj))
        (else obj)))

(define (thunk-memo? obj) (tagged-list? obj 'thunk-memo))
(define (delay-it-memo exp env) (list 'thunk-memo exp env))

测试用例：
1. (try 0 (/ 1 0))对于下面定义的执行情况：
 (define (try a b)
    (if (= a 0) 1 b))

 (define (try a (b lazy))
    (if (= a 0) 1 b))

2. 比较执行(factorial 1000)速度
(define (factorial n)
  (if (= n 1) 1 (* n (factorial (- n 1)))))
(define (factorial (n lazy))
  (if (= n 1) 1 (* n (factorial (- n 1)))))
(define (factorial (n lazy-memo))
  (if (= n 1) 1 (* n (factorial (- n 1)))))

ps: 开始看到参数中(b lazy)，lazy没有加上引号觉得奇怪，后来明白参数是直接传过去不经过求值的，也就不可以加上引用符号。


Section 4.2.3
可以用类似下面的方式来安装这些过程：
(define (install-compound-procs)
  (actual-value '(begin (define (cons x y)
                          (lambda(m) (m x y)))
                        (define (car x)
                          (x (lambda(p q) p)))
                        (define (cdr x)
                          (x (lambda(p q) q))))
                the-global-environment)
  ‘done)

4.32
巧了，第三章讨论过所谓的odd/even stream，也就和这里提到的"更加惰性"的表一样。
 
4.33
用的是类似于之前cond->if的派生表达式的做法，把'(1 2 3)改写为嵌套的cons，然后在环境中求值。
(define (text-of-quotation exp env)
  (define (helper x)
    (if (not (pair? x))
        x
        (list 'cons
              (car x)
              (helper (cdr x)))))
  (if (not (pair? (cadr exp)))
      (cadr exp)
      (actual-value (helper (cadr exp)) env)))
(put 'eval 'quote (lambda(exp env) (text-of-quotation exp env)))

4.34
比预想的要麻烦...
对于序对的表示，我只把car打印出来，这样有穷或是无穷的序对对此来说也没什么不同了。Drscheme本身的解释器功能比较强大，能打印出有环的序列。
大体思路是这样的：首先让解释器能识别出cons生成的过程与一般的过程的区别，然后在user-print中对其用car进行调用，得出结果打印。

为了让解释器分清cons与一般过程的不同，我新定义了一种语法形式special-lambda，相应的make-special-proc
(define (make-special-procedure name parameters body env) 
  (list (cons 'special-procedure name) parameters body env))
可以看到，这里多出一个name参数，使得它有一定的扩展性，而不只是检测cons这一个特殊过程。这样定义，也可以沿用原来的procedure-parameters和procedure-body过程。
相关的选择过程：
(define (special-procedure? proc)
  (if (pair? proc)
      (if (pair? (car proc))
          (eq? (caar proc) 'special-procedure)
          false)
      false))
(define (name-of-special-proc s-proc)
  (cdr (car s-proc)))
加入求值器：
(put 'eval 'special-lambda
       (lambda(exp env)
         (make-special-procedure (special-lambda-name exp)
                                 (special-lambda-parameters exp)
                                 (special-lambda-body exp)
                                 env)))
(define (special-lambda-name exp) (cadr exp))
(define (special-lambda-parameters exp) (caddr exp))
(define (special-lambda-body exp) (cdddr exp))

这样就可以这样定义cons:
(define (cons x y)
  (special-lambda cons (m) (m x y)))

 
apply过程需要修改，以便于识别special-procedure：
(define (apply procedure args env)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure
                                    (list-of-true-value args env)))
        ((special-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment
           (procedure-parameters procedure)
           (list-of-delayed-args args env)
           (procedure-environment procedure))))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment
           (procedure-parameters procedure)
           (list-of-delayed-args args env)
           (procedure-environment procedure))))
        (else (error "Unknown procedure type--APPLY" procedure))))

现在定义的cons已经可以运行，下面是打印过程的修改（只修改user-print即可）：
(define (user-print object)
  (if (compound-procedure? object)
      (display (list 'compound-procedure
                     (procedure-parameters object)
                     (procedure-body object)
                     '<procedure-env>))
      (if (special-procedure? object)
          (if (eq? (name-of-special-proc object) 'cons)
              (display (list
                    (force-it (apply object
                                     '((lambda(p q) p))
                                     the-global-environment))
                         'cdr-promise))                    
              (display object)))))   

效果：
;;; L-Eval input:
(cons 1 2)

;;; L-Eval output:
(1 cdr-promise)

;;; L-Eval input:
integers

;;; L-Eval output:
(1 cdr-promise)

;;; L-Eval input:
(cdr integers)

;;; L-Eval output:
(2 cdr-promise)             

这第一章写了三个星期……

Section 4.1.4
4.14
Louis同学直接引入的map不能使用的原因，是由于忽略了所求值语言和所用的scheme语言两者实现的不同。
考察这个过程：
(map (lambda(x) (+ 1 x)) '(1 2 3))
我们写的eval过程把它转换成
(apply (eval (operator exp) env)
       (list-of-values (operands exp) env))
在operator这部分并没有出现问题，即把map当作primitive-procedure进行匹配；问题出在参数上，参数按照我们写的解释器中的语法求值，而map调用的确实我们编程环境所用的scheme的语法规则。在这里，这个不同具体体现在过程的表示上，我们写的解释器表示过程用的是('procedure <args> <body> <env>)的形式，而scheme看起来实际上并不是恰好这样表示的(比如('closure <args> <body> <env>)之类的)。这就是map直接安装为primitive-procedure出错的原因。
这也解释了如果我们简单写一个(define (add-1 x) (+ 1 x))，而把add-1作为primitive-procedure安装到求值器中，运行结果正常的现象。

Section 4.1.5   
4.15
如果(try try)能停止，即(halts? try try)那么根据try的定义，它将run-forever；如果(try try)无限运行，则(halts? try try)为假，也就可以停机。矛盾出现。
   
Section 4.1.6
4.16
a) 添一句(if (eq? result '*unassigned*)
                (error "Unbound variable" var) 就ok了
b) scan-out-defines是用来改写lambda表达式中的body的。
(define (scan-out-defines procs)
  (let ((defines (exp-defines procs)))
    (if (null? defines)
        procs
        (let ((vars (defines-vars defines))
              (bodies (defines-bodies defines)))
          (list (make-let (map (lambda(x) (list x ''*unassigned*)) vars)  ;*unassigned*需要两个引号
                          (make-begin (append (map (lambda(var val) (list 'set! var val)) vars bodies)
                                  (exp-body procs)))))))))
(define (exp-defines procs)
  (filter definition? procs))
(define (exp-body procs)
  (filter (lambda(x) (not (definition? x))) procs))
(define (defines-vars defs) (map definition-variable defs))
(define (defines-bodies defs) (map definition-value defs))
c) 评定安装在那个位置好的标准定为哪种方案重复执行的次数最少。
推测放在eval中和放在make-procedure是一样的，而放在procedure-body中会执行的多一些。   
写了一个测试执行时间的程序：
(define eval-easy
    (lambda(x) (eval x the-global-environment)))
(define (test-eval proc)
  (start-test proc (current-inexact-milliseconds)))
(define (start-test proc time)
  (eval-easy proc)
  (- (current-inexact-milliseconds) time))
(define (test-eval-n proc n)
  (if (= n 0)
      0
      (+ (test-eval proc)
         (test-eval-n proc (- n 1)))))
用一个求乘方的过程来比较三者的效率：
(test-eval-n '(begin (define (expt-x xx)
                       (define (expt x n)
                         (if (= 0 n)
                             1
                             (* x (expt x (- n 1)))))
                       (define x 12345)
                       (expt 12345 xx))
                     (expt-x 10000))
             100)   
发现放入解释器和放入make-procedure结果是差不多的，而放入procedure-body会慢一些，符合预测。

4.17
图不画了。顺序执行的情况，u和v都是直接定义在所处环境里面，而通过scan-out-defines后u和v是作为参数应用到<e3>里，所以多了一层环境。
如果不构造额外的框架，那么就直接把u和v用define放进环境里面：
(define (scan-out-defines procs)
  (let ((defines (exp-defines procs)))
    (if (null? defines)
        procs
        (let ((vars (defines-vars defines))
              (bodies (defines-bodies defines)))
          (append (map (lambda(x) (make-definition x ''*unassigned*)) vars)
                  (append (map (lambda(var val) (list 'set! var val)) vars bodies)
                          (exp-body procs)))))))
                         
4.18
推测本题的过程不能用，而原文中的可以。那个a和b的“中转”作用，我认为是可以和直接set!等价的，问题出在顺序上。
(define (solve f y0 dt)
  (define y (integral (delay dy) y0 dt))
  (define dy (stream-map f y))
  y)
当时在第三章中试过，由于y定义中有(delay dy)，而dy定义中没有(delay y)，这样如果交换y和dy的定义顺序，程序是不能运行的。原文中是先给u赋值，再给v赋值；而本题我们知道同一层let中定义的变量相互是不可见的，所以在(a <e1>)没问题，当(b <e2>)时，所需要的u并不是(integral (delay dy) y0 dt)，而是*unassigned*，出错。如果把let改为let*，我想是可以成功的。

4.19
正像脚注所说的，Ben的观点是错误的，而Eva的观点实现起来有难度。
或许下面解决方案可行：
如果同一框架中有n个definition，那么就先用4.16中的方法给每个变量赋值*unassigned*。然后按下列规则扫描n次这些define语句：如果某条语句中变量全部能找到值，则执行该语句；如果某变量找到的值为*unassigned*，则此轮跳过该语句；否则报错。这样本题中问题就可以的到解决：首轮跳过b的定义，经过首轮内部a定义为5后，第二轮获得b的正确结果。
就是代价太高了。

4.20
a) 巧了，这里恰好可以用之前写得那个let*->defs过程，就是把let*写成一个个的define。
(define (eval-letrec exp env)
  (eval (letrec->defs exp) env))
(define (letrec-defs exp) (cadr exp))
(define (letrec-body exp) (caddr exp))
(define (letrec-defs->definitions defs)
  (if (null? defs)
      '()
      (let ((first (car defs)))
        (cons (make-definition (car first) (cadr first))
              (letrec-defs->definitions (cdr defs))))))
(define (letrec->defs exp)
  (cons 'begin (append (letrec-defs->definitions (letrec-defs exp))
                       (list (letrec-body exp)))))
添加到eval安装包：
(put 'eval 'letrec eval-letrec)
b)     主要原因是let不允许递归(用letrec解决)，而且同一级let的变量之间相互不是可见的(用let*解决)。                  

4.21
a) "递归程序设计的诡计"，怎么想出来的呢。还有那个Y运算符，目的是用Y来实现用有限的过程表示无限的递归调用，而如果所要调用的函数存在不动点，则用Y可以求出来。
(define (fibnacci n)
  ((lambda(fib)
    (fib fib n))
   (lambda(fb k)
     (cond ((= k 0) 1)
           ((= k 1) 1)
           (else (+ (fb fb (- k 1))
                    (fb fb (- k 2))))))))
b) 照猫画虎了...
(define (f x)
  ((lambda(even? odd?)
     (even? even? odd? x))
   (lambda(ev? od? n)
     (if (= n 0) #t (od? ev? od? (- n 1))))
   (lambda(ev? od? n)
     (if (= n 0) #f (ev? ev? od? (- n 1))))))
     
Section 4.1.7
4.22
这种语法分析与运行的分离感觉挺巧妙的，文中做的很是简单，大部分代码都能原封不动的继续用。我感觉需要稍微注意一下的地方就是analyze-assignment/analyze-definition中的变量名部分是不需要analyze的，而vproc部分在写进环境的不是语法分析的结果，而是需要应用到env上的结果。

写这个let跟4.6差不多：
(define (analyze-let exp)
  (let ((vars (map car (let-bindings exp)))
        (vals (map cadr (let-bindings exp)))
        (body (let-body exp)))
    (analyze (cons (make-lambda vars (list body)) vals))))
(define (let-bindings x) (cadr x))
(define (let-body x) (caddr x))
加入到包中：(put 'analyze 'let analyze-let)

4.23
试了几个例子，发现两者得出的结果是一样的，就有些困惑了。分析了一遍两者的运行过程，隐约觉得文中的舒服些，这里的有些别扭。后来看了下Eli的答案，原来区别不在于结果上。
比如一个过程序列(P1 P2 P3)，文中的analyze-sequence会直接把它分析为:
(lambda(env)
  ((lambda(env)
     ((lambda(env) (P1 env)) env)
     (P2 env))
   env)
  (P3 env))
然后直接在eval中应用到env上；
而本题的过程，语法分析和运行两者交织在一起，没有env时，execute-sequence是不能运行的。
也就是说，区别在于求值的过程，而不在于求值的结果。

4.24
用的4.16中的那个简单的整体测时间程序，用乘方来做实例：
(test-eval '(begin (define (expt-x xx)
                       (define (expt x n)
                         (if (= 0 n)
                             1
                             (* x (expt x (- n 1)))))
                       (define x 12345)
                       (expt 12345 xx))
                     (expt-x 10000)))
元循环求值器用了1300ms左右， 这里用了750ms                     
至于评估各种过程……设计实例太麻烦了，因为一句话的过程两者的运行时间都是0.0

先播放一个通知：ocaml.cn关闭，取而代之的是个叫做"babelnova.net"的新社区——就换了个名字，里面内容好像没怎么变。
这个"babel"指的是巴别塔，来源于圣经的一个小故事：大洪水过后，人们从方舟上下来闲的蛋疼，想建立一座通天塔，用来显示人类的力量和团结，这就是巴别塔。神们为了自己尊贵的地位，开始阻挠巴别塔的修建。手段就是让原本只说一种语言的人类交流不通，产生了N种不同的语言，最终成功组织了塔的通天。

Section 4.1.3
4.11
挺多过程都需要改：
(define (make-frame vars vals) (map list vars vals)) ;make-frame在extend-environment中还要用到
(define (add-binding-to-frame! var val frame)
  (set-cdr! frame (cons (car frame)
                        (cdr frame)))
  (set-car! frame (list var val)))
(define (frame-var binding) (car binding))
(define (frame-val binding) (cadr binding))

lookup-variable-value/set-variable-value!/define-variable! 这三个过程都需要修改
(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan bindings)
      (cond ((null? bindings) (env-loop (enclosing-environment env)))
            ((eq? var (frame-var (car bindings)))
             (frame-val (car bindings)))
            (else (scan (cdr bindings)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (scan frame))))
  (env-loop env))
(define (set-variable-value! var val env)
  (define (env-loop env)
    (define (scan bindings)
      (cond ((null? bindings) (env-loop (enclosing-environment env)))
            ((eq? var (frame-var (car bindings)))
             (set-car! (cdr (car bindings)) val))
            (else (scan (cdr bindings)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable--SET!" var)
        (let ((frame (first-frame env)))
          (scan frame))))
  (env-loop env))
(define (define-variable! var val env)  ;只在当前frame里面活动，所以没有env-loop
  (let ((frame (first-frame env)))
    (define (scan bindings)
      (cond ((null? bindings) (add-binding-to-frame! var val frame))
            ((eq? var (frame-var (car bindings)))
             (set-car! (cdr (car bindings)) val))
            (else (scan (cdr bindings)))))
    (scan frame)))
而初始环境the-global-environment不需要修改的原因就是构造过程已经抽象为make-frame了。

4.12
本题采用的frame表示为原文的表示方法，而不是4.11中的。
开始只想到把scan抽象出来，至于返回值或者赋值的选择作为一个参数传过去；写出来后觉得相当丑陋，思路不清。从Eli那里看到一个比较清晰的抽象：对frame的两个操作——查找和赋值。
(define (lookup-frame var vars values) ;找到了返回相应值, 否则返回next，不简单的用'()是因为(car values)可能为'()
  (cond ((null? vars) 'next)
        ((eq? var (car vars)) (car values))
        (else (lookup-frame var (cdr vars) (cdr values)))))
(define (set-frame-binding! var val vars values)  ;找到了改变其值，并返回新值，否则返回next
  (cond ((null? vars) 'next)
        ((eq? var (car vars)) (begin (set-car! values val)
                                     val))
        (else (set-frame-binding! var val (cdr vars) (cdr values)))))
这样改写这三个过程：
(define (lookup-variable-value var env)
  (define (env-loop env)
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (let ((result (lookup-frame var (frame-variables frame) (frame-values frame))))
            (if (not (eq? result 'next))
                result
                (env-loop (enclosing-environment env)))))))
  (env-loop env))
(define (set-variable-value! var val env)
  (define (env-loop env)
    (if (eq? env the-empty-environment)
        (error "Unbound variable--SET!" var)
        (let ((frame (first-frame env)))
          (let ((result (set-frame-binding! var val
                                            (frame-variables frame) (frame-values frame))))
            (if (not (eq? result 'next))
                result
                (env-loop (enclosing-environment env)))))))
  (env-loop env))
(define (define-variable! var val env) 
  (let ((frame (first-frame env)))
    (let ((result (set-frame-binding! var val
                                      (frame-variables frame) (frame-values frame))))
      (if (not (eq? result 'next))
          result
          (add-binding-to-frame! var val frame)))))
这样写出来整齐多了，美~

4.13
觉得define与set!不同，添加define的时候是只改变当前框架中的定义，类似的删除一个define也应只在当前框架内进行。
(define (make-unbound! var env)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars) (begin (display "not found")
                                 '()))
            ((eq? var (car vars))
             (begin (set-car! vars (cadr vars))
                    (set-cdr! vars (cddr vars))
                    'done))
            (else (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame) (frame-values frame))))
(define (eval-undefine! exp env)
  (make-unbound! (eval (cdr exp) env) env))
最后在install-package中加入eval-undefine!:
(put 'eval 'undefine! eval-undefine!)

猛地碰上一大段东西就不想看了……像2.5的通用算数、3.3.4中的数字电路，这次的Meta循环更是如此。其实难度倒是不深，就是东西太多了。
本小节的视频里头，Sussman大叔再讲完eval-apply循环后摇身一变，穿上袍子拿起火柴棍做了个魔法师的扮相。很有意思。
--08.8.18修改：4.6中let的错误
--08.8.19修改 : 随着let衍生的let* /name-let 等错误
Section 4.1.1
4.1
用let把值先求出来就好了
(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (let ((rest-result (list-of-values (rest-operands exps) env)))
        (cons (eval (first-operand exps) env)
              rest-result))))

Section 4.1.2             
4.2
a) 出错：Unbound variable: define
b) 由于整个系统模块化做的很好，所以修改一下appplication?及其选择函数就行。
(define (application? exp) (tagged-list? exp 'call))
(define (operator exp) (cadr exp))
(define (operands exp) (cddr exp))
需要注意的是以后即使是primitive-procedrue也要加上call。比如平方和过程：
(define (square x) (call * x x))
(define (sum-sq x y) (call + (call square x) (call square y)))

4.3
就像2.73里面一样，由于self-evaluating和variable都没有tag用来标记，所以需要写在cond中；而application也是没有tag，而且存在4.2中所说的顺序问题，所以加载special-form的数据导向分派的后面。运行driver-loop前先加载install-eval-package。
(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((get 'eval (get-tag exp))
         ((get 'eval (get-tag exp)) exp env))
        ((application? exp)
         (apply (eval (operator exp) env)
                (list-of-values (operands exp) env)))
        (else
         (error "Unknown expression type--EVAL" exp))))
         
(define (install-eval-package)
  (put 'eval 'if eval-if)
  (put 'eval 'quote (lambda(exp env) (text-of-quotation exp)))
  (put 'eval 'set! eval-assignment)
  (put 'eval 'define eval-definition)
  (put 'eval 'lambda (lambda (exp env)
                          (make-procedure (lambda-parameters exp)
                                          (lambda-body exp)
                                          env)))
  (put 'eval 'begin (lambda(exp env) (eval-sequence (begin-actions exp) env)))
  (put 'eval 'cond (lambda (exp env) (eval (cond->if exp) env)))
  'done)   
(define (get-tag x)
  (if (pair? x)
      (car x)
      (error "Not a pair--get-tag" x)))

4.4
a) (define (eval-and exp env)
      (if (null? (and-clauses exp))
          (error "No args--AND" exp)
          (let ((first (first-clause (and-clauses exp))))
            (cond ((last-exp? (and-clauses exp)) (eval first env))
                  ((false? (eval first env)) false)
                  (else (eval-and (rest-clauses exp) env))))))
    ;;最后一句(else (eval-and (rest-clauses exp)  env)) 道理上有些不对，不过实际上结果是正确的。
    (define (eval-or exp env)
      (if (null? (or-clauses exp))
          (error "No args--AND" exp)
          (let ((first (first-clause (or-clauses exp))))
            (cond ((last-exp? (or-clauses exp)) (eval first env))
                  ((true? (eval first env)) true)
                  (else (eval-or (rest-clauses exp) env))))))
    (define (and-clauses exp) (cdr exp))
    (define (or-clauses exp) (cdr exp))
    (define (first-clause clauses) (car clauses))
    (define (rest-clauses clauses) (cdr clauses)) 
    然后在eval包中加入:
      (put 'eval 'and eval-and)
      (put 'eval 'or eval-or)
b) 派生表达式：
(define (eval-and-if exp env)
  (eval (and->if (and-clauses exp) env) env))
(define (and->if clauses env)
  (if (null? clauses)
      'true
      (let ((first (car clauses)))
        (if (last-exp? clauses)
            first
            (make-if first
                     (and->if (rest-clauses clauses) env)
                     'false)))))

(define (eval-or-if exp env)
  (eval (or->if (or-clauses exp) env) env))
(define (or->if clauses env)
  (if (null? clauses)
      'true
      (let ((first (car clauses)))
        (if (last-exp? clauses)
            first
            (make-if first
                     'true
                     (or->if (rest-clauses clauses) env))))))
同样，在eval包中加入
(put 'eval 'and eval-and-if)
(put 'eval 'or eval-or-if)   

4.5
只修改cond-actions过程即可，cond->if和expand都不用改。
(define (recipient? clause)
  (eq? (cadr clause) '=>))
(define (cond-actions clause)
  (if (recipient? clause)
      (list (list (caddr clause) (cond-predicate clause)))  ;因为后面是sequence->exp
      (cdr clause)))   

4.6     
(define (eval-let exp env)
  (eval (let->combination exp) env))
(define (let->combination exp)
  (cons (make-lambda (let-vars exp)  ;是cons 而不是list
                     (let-body exp))
        (let-bindings exp)))
(define (let-var-clauses exp) (cadr exp))
(define (let-body exp) (cddr exp))
(define (let-vars exp)
  (map car (let-var-clauses exp)))
(define (let-bindings exp) (map cadr (let-var-clauses exp)))
最后在eval包中加入eval-let:
(put 'eval 'let eval-let)

4.7
08/8/18修改：(define (let*-body exp) (caddr exp))
let*的两个条件：1)同一环境  2)由左至右约束可见。这也就相当于一层层的扩充一个环境，可以用嵌套let或者一系列的define来实现。
(define (eval-let* exp env)
  (eval (let*->nested-lets exp) env))
(define (let*->nested-lets exp)
  (if (null? (let*-defs exp))
      (let*-body exp)
      (let ((first (car (let*-defs exp)))
            (rest (cdr (let*-defs exp))))
        (make-let (list first) (let*->nested-lets
                                (make-let* rest (let*-body exp)))))))
(define (let*-defs exp) (cadr exp))
(define (let*-body exp) (caddr exp))
(define (make-let* definitions body) (list 'let definitions body))
加入eval包:
  (put 'eval 'let* eval-let*)
 
ps: 后来又写了一个把let*转为一堆define的过程，试了几个结果也都正确。
(define (eval-let* exp env)
  (eval (let*->defs exp) env))
(define (let*-defs exp) (cadr exp))
(define (let*-body exp) (caddr exp))
(define (let*-defs->definitions defs)
  (if (null? defs)
      '()
      (let ((first (car defs)))
        (cons (make-definition (car first) (cadr first))
              (let*-defs->definitions (cdr defs))))))
(define (let*->defs exp)
  (cons 'begin (append (let*-defs->definitions (let*-defs exp))
                       (list (let*-body exp)))))
       
4.8
;name-let: (let <var> <bindings> <body>)--------
实现方法是先define一个名字是<var>的过程(调用自身)，然后调用<bindings>中的形参和实参。
修改后的let->combination
(define (let->combination exp)
  (if (name-let? exp)
      (let ((def-name (make-definition (name-let-var exp)
                                       (make-lambda (name-let-binding-vars exp)
                                                    (list (name-let-body exp)))))
            (values (name-let-binding-values exp)))
        (make-begin (list def-name
                          (cons (name-let-var exp) values))))
      (cons (make-lambda (let-vars exp)
                         (list (let-body exp)))
              (let-bindings exp))))
;一些选择函数
(define (name-let? exp) (and (not (null? (cadr exp)))
                             (not (pair? (cadr exp)))))
(define (name-let-binding-vars exp) (map car (caddr exp)))
(define (name-let-binding-values exp) (map cadr (caddr exp)))
(define (name-let-body exp) (cdddr exp))  ;不是cadddr 而是cdddr
(define (name-let-var exp) (cadr exp))

4.9
while比较简单:
;---------while ::=(while <cond> <body>)------
(define (eval-while exp env) (eval (while->combination exp) env))
(define (while->combination exp)
  (make-if (while-cond exp)
           (make-begin (list (while-body exp)
                             (make-while (while-cond exp)
                                         (while-body exp))))
           ''done))  ;需要两层引用
(define (while-cond exp) (cadr exp))
(define (while-body exp) (cddr exp))
(define (make-while condition body) (list 'while condition body))
之后加入eval包(put 'eval 'while eval-while)

;test
;;; M-Eval input:
(define x 10)
(while (> x 0) (begin (set! x (- x 1))
                      (display x)))
9876543210
;;; M-Eval output:
done


再写个for:用的是let的嵌套来实现每次循环后for中变量的变化。感觉用set!也是可以的
;-------for ::=(for <primitive> <condition> <change> <body>)
(define (eval-for exp env) (eval (for->combination exp) env))
(define (for->combination exp)
  (make-let (list (for-primitive exp))
            (make-if (for-cond exp)
                     (make-begin (list (for-body exp)
                                       (make-for (list (car (for-primitive exp))
                                                       (list (for-change exp) (cadr (for-primitive exp))))
                                                 (for-cond exp)
                                                 (for-change exp)
                                                 (for-body exp))))
                     ''done)))

(define (for-primitive exp) (cadr exp))
(define (for-cond exp) (caddr exp))
(define (for-change exp) (cadddr exp))
(define (for-body exp) (cddddr exp))
(define (make-for primitive condition change body)
  (list 'for primitive condition change body))
加入eval包：(put 'eval 'for eval-for) 

;test
;;; M-Eval input:
(for (i 0) (< i 10) (lambda(x) (+ x 1))
     (begin (newline)
            (for (j 0) (< j 10) (lambda(x) (+ x 1))
                 (display '*))))

**********
**********
**********
**********
**********
**********
**********
**********
**********
**********
;;; M-Eval output:
done
  ——效果还不错！
 
4.10
题中所说的"一种新的语法形式"，我认为也就是S-expression中元素顺序变变，至于把类似把括号去掉这种语法上的改动当前是不能实现的。
例子的话，之前EX 4.2中Louis同学的(call factorial 3)就可以算作一个了。
     
     


        

3.81
不太明白，如果generate也和原来一样，每使用一次变一下，那不就是同样的过程返回不同结果了么。

3.82
需要实现random-in-range：
这里遇到一个问题：两个随机序列到底是应该从一个random-numbers中陆续的抽取，还是直接生成两个random-numbers?
暂且选择是从一个random-numbers中抽取：
(define (random-update x)                       ;一种简便的生成随机数的方法
    (remainder (+ 37 (* x 16807)) 2147487))
(define rand
  (cons-stream 1
               (stream-map random-update rand)))
(define rand-numbers (scale-stream rand (/ 1 2147487.0)))    ;使得随机数值在0~1之间
(define (helper rand-stream)
    (cons-stream (stream-car rand-stream)
                 (helper (stream-cdr (stream-cdr rand-stream)))))
(define random-1 (helper rand-numbers))
(define random-2 (helper (stream-cdr rand-numbers)))
(define (random-in-range low high rand-strm)
  (stream-map (lambda(x) (+ low x)) (scale-stream rand-strm (- high low))))
 
estimate-integral过程：
(define (estimate-integral x1 x2 y1 y2 p?)
  (define random-x (random-in-range x1 x2 random-1))
  (define random-y (random-in-range y1 y2 random-2))
  (define p-test (stream-map p? random-x random-y))
  (define rect-area
    (* (abs (- x1 x2))
       (abs (- y1 y2))))
  (define e-i-result (scale-stream (monte-carlo p-test 0 0) rect-area))
  e-i-result)
 
测试：
(define (f? x y)
  (<= (+ (square (- x 5))
         (square (- y 7)))
     9))
(define result (estimate-integral 2.0 8.0 4.0 10.0 f?))
结果还不错，看了10000项，最后稳定在28.11左右


终于完成了传说中"平易近人"的前三章——至少是对绝大部分习题都有了个交代。至于很多内容的延伸，就留给以后了，毕竟这本书涉及到的东西很广……

在integral过程迷惑了一段时间才明白：这里的t就是平时做积分的自变量x，输入流integrand是自变量以dt逐渐变化时，因变量y所对应的值。则根据积分定义，如果输入integrand是y的值，输出就是y的积分；y0就是y(0)，可以说是用来确定积分后面+的那个C的；积分区间从t=0开始，到输出流某元素的stream-ref*dt那个值为止。
另外一个地方我与书上意见不同：对于dy/dt=f(y)那个图，map:f输出的应该是dy/dt，而不单单是dy吧。

3.77
加几个force，加一个delay
(define (integral integrand init-value dt)
  (cons-stream init-value
               (if (empty-stream? (force integrand))
                   '()
                   (integral (delay (stream-cdr (force integrand)))
                             (+ (* dt (stream-car (force integrand)))
                                init-value)
                             dt))))

3.78
感觉知其然不知其所以然……就这么用数值解2阶线性微分方程？
(define (solve-2nd a b dt y0 dy0)
  (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)

>(stream-ref (solve-2nd 0 1 0.001 1 1) 1000)
2.716923932235896

3.79
(define (solve-2nd dt y0 dy0 f)
  (define y (integral (delay dy) y0 dt))
  (define dy (integral (delay ddy) dy0 dt))
  (define ddy (f dy y))
  y)
 
3.80
字面上的证明很容易，略之。
(define (RLC R L C dt)
  (define (RLC-helper 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 (/ 1 L))
                             (scale-stream il (/ (* -1 R) L))))
   
   
    (stream-map cons vc il))
  RLC-helper)
(define xx ((RLC 1 1 0.2 0.1) 10 0))


总结：只是照样子把过程都写了出来，但是每个过程的意思到现在还没什么概念。以后应该重看这一节


                            

3.63
回想当初的银行账户：
(define (make-account amount)
  (let ((balance amount))
    (lambda(m)
      (cond ((eq? m 'balance) balance)
            ((eq? m 'withdraw)
             (lambda(x)
               (begin (set! balance (- balance x))
                      balance)))))))
只有像(define a (make-account 100))这样define了一个a，才能实现连续的改变帐户中的钱数，而直接应用过程(((make-account 100) 'withdraw) 27)是不行的。我认为原因就在于a给了一个位置，这样使得后来的withdraw过程都只会去访问a中包含的balance；而直接应用make-account的话，每一次访问的都是一个新的balance。

联系本题，定义了guesses的话，当再次访问流中某stream-cdr时，memo-proc就会查找同一个already-run?和result；而如果没有guesses这个位置的话，memo-proc就不知从何去找了。



3.64
(define (stream-limit s n)
  (cond ((empty-stream? s) "No such elements")
        ((< (abs (- (stream-car s)
                    (stream-car (stream-cdr s))))
            n)
         (stream-car (stream-cdr s)))
        (else (stream-limit (stream-cdr s) n))))

3.65
(define (ln2-series n)
  (cons-stream (/ 1.0 n)
               (stream-map - (ln2-series (+ n 1)))))
(define ln2 (partial-sums (ln2-series 1)))
(define ln2-euler (euler-transform ln2))
(define super-ln2 (accelerated-sequence euler-transform ln2))

3.66
由于interleave是轮流取值，所以(a b)前面元素中诸如(x y) (x>=a)这种就大约应该是(x=a)的2倍；确定了本层的，再逐渐上升求出上一层，知道a=0。
具体说：1)本层中在本元素前的个数： 对于(a b)，当a!=b时，个数为(b-a)*2-1；当a=b，0
        2)令本层所求元素前的元素个数为x，那么上一层相应个数就应为(x+1)*2，迭代n次的话结果为x*2^n+2^(n+1)-2。如此迭代(a-0)次。
        这样得到最终结果：对于(a b), a!=b时，(b-a)*2^(a+1)+2^a-2; a=b时，2^(a+1)-2。
       
3.67
先把其余的序对列举出来，然后和原来的用interleave合成
(define (miner-pairs s t)
  (cons-stream
   (list (stream-car (stream-cdr s)) (stream-car t))
   (interleave
    (stream-map (lambda(x) (list x (stream-car t)))
                (stream-cdr (stream-cdr s)))
    (miner-pairs (stream-cdr s) (stream-cdr t)))))
(define (real-pairs s t)
  (interleave (pairs s t)
              (miner-pairs s t)))
             
3.68
Louis同学的过程不会返回值，怀疑是与延迟求值有关系

3.69
和pairs类似的分割方法，调用了pairs
(define (triples s t u)
  (cons-stream (list (stream-car s) (stream-car t) (stream-car u))
               (interleave (stream-map (lambda(x)
                                         (cons (stream-car s) x))
                                       (stream-cdr (pairs t u)))   ;;第一项是t0u0 已算过
                           (triples (stream-cdr s)
                                    (stream-cdr t)
                                    (stream-cdr u)))))   

3.70
这题费了点时间
先写个merge。相比较之前的merge过程，除了增加了一个参数weight，还取消了删除相同项的功能——这一点是必需的。
(define (merge s1 s2 weight)
  (cond ((empty-stream? s1) s2)
        ((empty-stream? s2) s1)
        ((> (weight (stream-car s2)) (weight (stream-car s1)))
         (cons-stream (stream-car s1)
                      (merge (stream-cdr s1) s2 weight)))
        (else (cons-stream (stream-car s2)
                           (merge s1 (stream-cdr s2) weight)))))
上三角矩阵(A[i,j] i<=j)可以这样排序：A[0,0]在先，接下来的是A[0 ,1~n] 和 A[1~n, 1~n]中的较小项。其中A[0,1~n]是排好序的，A[1~n, 1~n]可以递归到上三角矩阵的排序。
(define (min-matrix-triangle s t weight)
  (cons-stream (list (stream-car s) (stream-car t))
               (merge (stream-map (lambda(x) (list (stream-car s) x))
                                  (stream-cdr t))
                      (min-matrix-triangle (stream-cdr s) (stream-cdr t) weight)
                      weight)))
类似的下三角：
(define (min-matrix-down-triangle s t weight)
  (cons-stream (list (stream-car (stream-cdr s)) (stream-car t))
               (merge (stream-map (lambda(x) (list x (stream-car t)))
                                  (stream-cdr (stream-cdr s)))
                      (min-matrix-down-triangle (stream-cdr s) (stream-cdr t) weight)
                      weight)))
如果需要整个矩阵，只需把两个三角merge起来就行了                     
1)只需要上三角
(define S (min-matrix-triangle integers integers sum-weight))
(define (sum-weight a)
  (+ (car a) (cadr a)))
2)只需要上三角
(define x (min-matrix-triangle 235-series 235-series 235sum-weight))
(define (235sum-weight a)
  (let ((a1 (car a)) (a2 (cadr a)))
    (+ (* 2 a1) (* 3 a2) (* 5 a1 a2))))
这里生成数列所用的merge需要排除掉重复元素
(define 235-series (merge-with-equal (scale-stream integers 3)
                                     (merge-with-equal (scale-stream integers 2)
                                                       (scale-stream integers 5)
                                                       value-weight)
                                     value-weight))
(define (merge-with-equal s1 s2 weight)
  (cond ((empty-stream? s1) s2)
        ((empty-stream? s2) s1)
        ((> (weight (stream-car s2)) (weight (stream-car s1)))
         (cons-stream (stream-car s1)
                      (merge-with-equal (stream-cdr s1) s2 weight)))
        ((> (weight (stream-car s1)) (weight (stream-car s2)))
         (cons-stream (stream-car s2)
                      (merge-with-equal s1 (stream-cdr s2) weight)))
        (else (cons-stream (stream-car s1)
                           (merge-with-equal (stream-cdr s1) (stream-cdr s2) weight)))))

3.71
修改了一下merge-with-equal，使得Ramanujan数更明显一点
(define (merge-with-equal s1 s2 weight)
  (cond ((empty-stream? s1) s2)
        ((empty-stream? s2) s1)
        ((> (weight (stream-car s2)) (weight (stream-car s1)))
         (cons-stream (stream-car s1)
                      (merge-with-equal (stream-cdr s1) s2 weight)))
        ((> (weight (stream-car s1)) (weight (stream-car s2)))
         (cons-stream (stream-car s2)
                      (merge-with-equal s1 (stream-cdr s2) weight)))
        (else (cons-stream (append (stream-car s1) (stream-car s2) (cons '!!! (weight (stream-car s1))))
                           (merge-with-equal (stream-cdr s1) (stream-cdr s2) weight)))))
(define (cube x) (* x x x))
(define (cube-sum-weight x)
  (let ((a1 (car x)) (a2 (cadr x)))
    (+ (cube a1) (cube a2))))
(define S (min-matrix-triangle integers integers cube-sum-weight))   
用这个过程来检查：
(define (Raman s)
  (if (= (cube-sum-weight (stream-car s))
         (cube-sum-weight (stream-car (stream-cdr s))))
      (cons-stream (list (cons (stream-car s) (stream-car (stream-cdr s)))
                         (cube-sum-weight (stream-car s)))
                   (Raman (stream-cdr s)))
      (Raman (stream-cdr s))))
(display-stream(Raman S))

输出：
(((9 10) 1 12) 1729)
(((9 15) 2 16) 4104)
(((18 20) 2 24) 13832)
(((19 24) 10 27) 20683)
(((18 30) 4 32) 32832)
(((15 33) 2 34) 39312)
(((16 33) 9 34) 40033)
(((27 30) 3 36) 46683)
(((26 36) 17 39) 64232)
(((31 33) 12 40) 65728)
(((36 40) 4 48) 110656)
(((27 45) 6 48) 110808)
(((38 43) 12 51) 134379)
(((29 50) 8 53) 149389)
(((38 48) 20 54) 165464)
(((24 54) 17 55) 171288)...

3.72
(define (square-sum-weight a)
  (define (square x) (* x x))
  (+ (square (car a)) (square (cadr a))))
(define X (min-matrix-triangle integers integers square-sum-weight))
(define (choose x weight)
  (let ((x0 (stream-ref x 0))
        (x1 (stream-ref x 1))
        (x2 (stream-ref x 2)))
    (if (= (weight x0) (weight x1) (weight x2))
        (cons-stream (list x0 x1 x2 (list (weight x0)))
                     (choose (stream-cdr x) weight))
        (choose (stream-cdr x) weight))))
(define ym (choose X square-sum-weight))

> (display-stream ym)
((10 15) (6 17) (1 18) (325))
((13 16) (8 19) (5 20) (425))
((17 19) (11 23) (5 25) (650))
((14 23) (10 25) (7 26) (725))
((19 22) (13 26) (2 29) (845))
((15 25) (11 27) (3 29) (850))
((21 22) (14 27) (5 30) (925))
((20 25) (8 31) (1 32) (1025))
((23 24) (12 31) (9 32) (1105))
((12 31) (9 32) (4 33) (1105))
((25 25) (17 31) (5 35) (1250))
((20 30) (12 34) (2 36) (1300))
((22 29) (13 34) (10 35) (1325))
……


3.73
(define (RC R C dt)
  (lambda (i-stream init-v)
    (add-streams (stream-map (lambda(x) (+ (* x R) init-v)) i-stream)
                 (scale-stream (integral i-stream 0 dt) (/ 1 C)))))       
大概是这样吧，没测试

3.74
差别在于原过程可以附一个初始值last-value来比较
(define zero-crossings
  (stream-map sign-change-detector sense-data (stream-cdr sense-data)))       

3.75
Louis同学的平均值不是对应的sense-data的两个元素的平均值，一直累加的平均值运算
(define (make-zero-crossings input-stream last-value last-avg)
  (let ((avpt (/ (+ (stream-car input-stream) last-value) 2)))
    (cons-stream (sign-change-detector avpt last-avg)
                 (make-zero-crossings (stream-cdr input-stream)
                                      (stream-car input-stream)
                                      avpt))))
last-value是用来做平均值的，last-avg是用来求sign-change-detector的                                     

3.76
(define (smooth2 s)
  (stream-map average s (stream-cdr s)))
(define (make-zero-crossings the-strm smooth-method)
  (stream-map sign-change-detector
              (smooth-method the-strm)
              (stream-cdr (smooth-method the-strm))))
 

  3.53
 1, 2, 4, 8, 16...
 
 3.54
 (define (mul-streams s1 s2)
  (stream-map * s1 s2))
 (define factorials (cons-stream 1 (mul-streams integers factorials)))
 
 3.55
 (define (partial-sums strm)
  (cons-stream (stream-car strm)
               (add-streams (partial-sums strm)
                            (stream-cdr strm))))
                           
3.56
感觉这个很神奇：
(define S (cons-stream 1 (merge (scale-stream S 2)
                                (merge (scale-stream S 3)
                                       (scale-stream S 5)))))   

3.57
有memo-proc: 执行的加法次数就是书中所给的长串加法式子里的次数，即n-2(n>=3)
无memo-proc: 这时求值过程都不会保存，即每次求一个流的stream-car都要从头开始，那么(fib n)的加法次数也就相当于(fib (- n 1))和(fib (- n 2))次数之和再+1——与最开始介绍的那个递归过程相同。
也就是说，stream相对于list改变的只是惰性求值，而存储功能方面两者是没有本质区别的，都需要自行加载memo过程。

3.58
这不就相当于除法么
(expand 1 7 10)--->(1 4 2 8 5 7 1 4 2...)
(expand 3 8 10)--->(3 7 5 0 0 ...)
不过这过程还是不能用来计算其他进制，即radix一般也就是10

3.59
a)
(define (div-streams s1 s2)
  (stream-map / s1 s2))
(define (integrate-series series)
  (div-streams series integers))
   
b)真是感觉很神奇……完成如此功能代码量却这么少，但是每个方面道理又是很简单，还需要再好好理解一下
(define consine-series
  (cons-stream 1 (scale-stream (integrate-series sine-series)
                               -1)))
(define sine-series
  (cons-stream 0 (integrate-series consine-series)))
 
3.60
第二章计算多项式s1,s2乘法时，系数是这样计算的：写了一个单项与多项式相乘的过程，之后把s1分解为单项之和，分别于s2乘积最后求和。
但这种方法本题是不行的，因为流s1,s2都是无穷长的。流的观点是每次求出最后结果中的当前部分——本题来说也就是乘积次数最低项的系数(流中的先后顺序表示着次数的高低)。
这里每次我们只能确定最低的两个系数
(define (mul-series s1 s2)
  (cond ((empty-stream? s1) '())
        ((empty-stream? s2) '())
        (else (cons-stream (* (stream-car s1)
                              (stream-car s2))
                           (add-streams (mul-series s1 (stream-cdr s2))
                                        (scale-stream (stream-cdr s1) (stream-car s2)))))))
;test
(define isone (add-streams (mul-series cosine-series cosine-series)
                           (mul-series sine-series sine-series)))
>(display-stream isone)
1
0
0
0
...                          
                                       
3.61   
相对于3.62的除法，我觉得这个求倒数的过程要神奇的多。思想很明确：每次确定次数最低的项。不清楚第一个想出这方法的牛是怎么得到这个结果的。
(define (X s)
  (cons-stream 1
               (mul-series (scale-stream (stream-cdr s) -1)
                           (X s))))

3.62
(define (div-series s1 s2)
  (let ((scale (stream-car s2)))
    (if (not (= scale 0))
        (mul-series (scale-stream s1 (/ 1 scale))
                    (X (scale-stream s2 (/ 1 scale))))
        (error "Div-by-0  ---div-series" s2))))
tan-series显而易见：
(define tan-series (div-series sine-series cosine-series))       
> (display-stream tan-series)

0
1
0
1/3
0
2/15
...
                                      

3.50
(define (stream-map proc . argstreams)
  (if (empty-stream? (car argstreams))
      '()
      (cons-stream
       (apply proc (map stream-car argstreams))
       (apply stream-map
              (cons proc (map stream-cdr argstreams))))))
             
3.51
> (define x (stream-map show (stream-enumerate-interval 0 10)))

0
> (stream-ref x 5)

1
2
3
4
55
> (stream-ref x 7)

6
77

解释：由于这里采用的odd-stream，所以定义stream时候就已经把stream-car求出来了，所以第一句会有显示；后面每次stream-cdr一次，就要求值一次stream-car，至于为什么第二句里面没有0、第三句里没有012345，是由于memo-proc的缘故——只记录返回值，不再重复求值过程。
我用even-stream又做了一次，第一句没有输出，第二句输出012345，第三句不变。

3.52
> (stream-ref y 7)
136
> (display-stream z)

10
15
45
55
105
120
190
210done

当memo-proc存在时，赋值语句只执行一次，如果以后再次访问accum中已计算过的元素，程序会从memo中直接取值，而不执行set!语句。
如果不用memo-proc，那么accum就是一个变化的流——每访问一次值就发生变化。

在文档:SRFI 40: A Library of Streams 中找到的:
由于stream中的cons-stream需要实现为special-form，所以仅仅(define (cons-stream a b) (cons a (delay b)))是不行的，下面的过程是在Drscheme的文档里面找的，直接拷过去就能用。
(define (empty-stream? strm)               
  (null? strm))                    
                   
(define-syntax cons-stream               
  (syntax-rules ()                 
    ((cons-stream obj strm)              
      (cons obj (delay strm)))))   
                   
(define (stream-car strm)                
  (car strm))                      
                   
(define (stream-cdr strm)                
  (force (cdr strm)))
——force，delay是scheme的基本过程,不知道delay里面有没有memo-proc过程。

另外在文档里还发现一个小知识：流的这种惰性求值分两种：一种就是一般scheme用的，也是SICP里面讲的，叫做odd streams; 另外一种是Haskell这种纯函数式语言用的,叫做even streams. 区别在于odd中的stream-cdr是lazy的, 但是stream-car不是lazy的; 而even中两者都是lazy的, 在需要时候才求值.
两种stream的实现:
;;; FIGURE 1 -- ODD                
                   
(define nil1 '())                  
                   
(define (nil1? strm)               
  (null? strm))                    
                   
(define-syntax cons1               
  (syntax-rules ()                 
    ((cons1 obj strm)              
      (cons obj (delay strm)))))   
                   
(define (car1 strm)                
  (car strm))                      
                   
(define (cdr1 strm)                
  (force (cdr strm)))              
                   
(define (map1 func strm)           
  (if (nil1? strm)                 
    nil1                           
    (cons1                         
      (func (car1 strm))           
      (map1 func (cdr1 strm)))))   
                   
(define (countdown1 n)             
  (cons1 n (countdown1 (- n 1))))  
                   
(define (cutoff1 n strm)           
  (cond                            
    ((zero? n) '())                
    ((nil1? strm) '())             
    (else                          
      (cons                        
        (car1 strm)                
        (cutoff1 (- n 1)            
                 (cdr1 strm))))))   

;;; FIGURE 2 -- EVEN

(define nil2 (delay '()))

(define (nil2? strm)
  (null? (force strm)))

(define-syntax cons2
  (syntax-rules ()
    ((cons2 obj strm)
     (delay (cons obj strm)))))

(define (car2 strm)
  (car (force strm)))

(define (cdr2 strm)
  (cdr (force strm)))

(define (map2 func strm)
  (delay (force
    (if (nil2? strm)
      nil2
      (cons2
        (func (car2 strm))
        (map2 func (cdr2 strm)))))))

(define (countdown2 n)
  (delay (force
    (cons2 n (countdown2 (- n 1))))))

(define (cutoff2 n strm)
  (cond
    ((zero? n) '())
    ((nil2? strm) '())
    (else
      (cons
        (car2 strm)
        (cutoff2 (- n 1)
                 (cdr2 strm))))))
                 
之后举了个例子区别两者:
> (define (12div n) (/ 12 n))      
> (cutoff1 4                       
    (map1 12div (countdown1 4)))   
error: divide by zero              

> (define (12div n) (/ 12 n))
> (cutoff2 4
    (map2 12div (countdown2 4)))
(3 4 6 12)

原因就是在计算(cutoff 0 stream)的时候, 本来是不需要考虑stream的值, 但是odd-stream会把stream-car计算出来,也就出现了除数为0的错误; even-stream则一直懒着, 反正又没计算到头上, 不去管它. 和当时迷糊人的习题1.5有些类似.

感觉那个parallel-execute过程那么混乱呢……完全不能用来观察并发中各种可能的结果，所以下面结果只是自己人脑演算出来而不是具体过程试验结果。

3.38 不画图了，大概说一下
a) 令a=Peter, b=Paul, c=Mary
    45(abc/bac)/35(acb)/50(bca)/40(cba/cab)
b)
30：(set! balance ..Peter.. (/ balance 2))  Paul   ----表示在Peter得到(/ balance 2)之后但是set!之前运行Peter的过程，然后运行Paul的过程，下同
55：(set! balance ..Paul.. (+ balance 10))   Mary
80: (set! balance ..Peter.. ..Mary.. (- balance 2))
90: (set! balance ..Mary.. (+ balance 10))  Paul
110:(set! balance ..Paul.. ..Mary.. (+ balance 10))
其他的都是重复的值

3.39
100/101/121  跟上面差不多道理

3.40
可能出现10^2/10^3/10^4/10^5/10^6
如果采用了串行化过程，只会10^6

3.41
由于查询balance并不改变balance的值，所以我认为对于这类没有赋值在内的过程没必要进行串行化控制。

3.42
在安全性或者并发性方面没看出什么不同……

3.43
假设有(exchange a1 a2)/(exchange a2 a3)两个交换进程。如果e2插在e1的withdraw和deposit之间完成，那么最后结果就是(20 20 20)。
不画图了

3.44
transfer和exchange都有一个withdraw和一个deposit，本质区别在于要改变多少，即transfer的amount和exchange的difference。可以看出，amount相对于时间是个绝对的值，而difference是相对的，因为它要读取当前两个帐户的状态而进行运算。由于这个区别的存在，transfer过程就不需要像exchange那样的串行过程。Louis同学多虑了。

3.45
先分析本来的过程——关键一点是注意到serialized-exchange是被两个serializer约束的，其中用来改变帐户的withdraw和deposit过程都没用serializer约束！
而Louis同学的serialized-exchange过程中的withdraw和deposit相当于套了两层的串行约束，这样就相当于子过程与父过程变成了串行的，父进程完成之前子进程阻塞，而子进程不进行的话父进程也不可能完成——死锁了。

3.46
如果test-and-set!不是原子操作，假设两个进程t1和t2都执行了(mutex 'acquire)，当t2的申请过程在t1检查完(car cell)之后、(set-car! cell true)之前，那么t1和t2都能得到运行，也就失去了串行化的控制。

3.47
记得操作系统里面讲过怎么构造这东西，不过好像当时只用了mutex，没说test-and-set!(当时貌似叫做test&lock)的方面。
(define (make-n-serializer n)
  (let ((semaphore (make-semaphore n)))
    (lambda(f)
      (define (serialized-f . args)
        (semaphore 'P)
        (let ((val (apply f args)))
          (semaphore 'V)
          val))
      serialized-f)))
a) 用mutex
(define (make-semaphore n)
  (let ((limit n)
        (mutex (make-mutex)))
    (define (dispatch m)
      (cond ((eq? m 'P)
             (begin (mutex 'acquire)
                    (if (< n 0)
                        (begin (mutex 'release)
                               (dispatch 'P))
                        (begin (set! n (- n 1))
                               (mutex 'release)))))
            ((eq? m 'V)
         (begin
           (mutex 'acquire)
           (set! n (+ n 1))
           (mutex 'release)))))
    dispatch))
b) 用test-and-set!
如果用规约的方法就是用test-and-set!实现一个mutex，再调用上面的过程……
(define (make-semaphore n)
  (let ((limit n)
        (cell (list false)))
    (define (dispatch m)
      (cond ((eq? m 'P)
             (if (test-and-set! cell)
                 (dispatch 'P)
                 (if (< n 0)
                     (begin (clear! cell)
                            (dispatch 'P))
                     (begin (set! n (- n 1))
                            (clear! cell)))))
            ((eq? m 'V)
             (if (test-and-set! cell)
                 (dispatch 'V)
                 (begin ((set! n (+ n 1))
                         (clear! cell)))))))
      dispatch))
     
3.48
原来实现中出现死锁的原因是a1和a2的环路等待，即持有a1的进程去申请a2,持有a2的进程去申请a1。如果对帐户编号，使得不管(exchange a1 a2)还是(exchange a2 a1)都先去申请a1再申请a2，那样就不会存在环路等待的条件。
(define (make-account balance rank)
  (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 'rank) rank)
            (else (error "Unknown request---Make-account") m)))
    dispatch))

(define (serialized-exchange a1 a2)
  (let ((s1 (a1 'serializer))
        (s2 (a2 'serializer))
        (r1 (a1 'rank))
        (r2 (a2 'rank)))
    (cond ((< r1 r2) ((s1 (s2 exchange)) a1 a2))
          ((> r1 r2) ((s2 (s1 exchange)) a1 a2))
          (else (error "Same rank?" (list a1 a2))))))
         
3.49
正如提示所说，如果进程不能确定自己都需要什么资源，那就很难用这种资源优先级的方法来防止死锁发生了。具体例子没想到。

---------constraint-----------
3.33
(load "constraint.scm")
(define (averager a b c)
  (let ((temp (make-connector))
        (const-2 (make-connector)))
    (adder a b temp)
    (multiplier const-2 c temp)
    (constant 2 const-2)
    'ok))

3.34
LouisReasoner同学的平方器不能计算平方根。原因也很明显：我们平时也不能简单的用除法计算平方根，当然constraint系统也不会那么聪明。

3.35
(load "constraint.scm")
(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 (* (get-value a) (get-value a)) me))))
  (define (process-forget-value)
    (forget-value! a me)
    (forget-value! b me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value) (process-new-value))
          ((eq? request 'I-lost-my-value) (process-forget-value))
          (else (error "Unknown request----SQUARER" request))))
  (connect a me)
  (connect b me)
  me)
 
3.36
见图

3.37
(load "constraint.scm")
(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/ x y)
  (let ((z (make-connector)))
    (multiplier y z x)
    z))
(define (cv n)
  (let ((z (make-connector)))
    (constant n z)
    z))

以后改为章节为单位组织答案，这样整齐一些。
--------digital-circuit-------
3.30
建立一个局部list:l-c，用来传递进位信号。然后用connect过程把最后一个仅为信号与输出c连接起来。
(load "digital_circuit.scm")
(define (ripple-carry-adder l-a l-b l-s c) ;假设l-a l-b相同长度
  (let ((l-c (make-wire-list (+ (length l-a) 1))))  ;c的car为c-in，cadr为c-out
    (define (helper la lb ls lc)
      (if (null? la)
          'ok
          (let ((a (car la))
                (b (car lb))
                (c-in (car lc))
                (s (car ls))
                (c-out (cadr lc)))
            (begin (full-adder a b c-in s c-out)
                   (helper (cdr la) (cdr lb) (cdr ls) (cdr lc))))))
    (helper l-a l-b l-s l-c)
    (connect (last l-c) c)))
(define (connect in out)
  (define (connect-proc)
    (after-delay 0 (lambda() (set-signal! out (get-signal in)))))
  (add-action! in connect-proc))
;一些边边角角的过程：
(define (last l)
  (cond ((not (pair? l)) (error "Not a pair--" l))
        ((null? (cdr l)) (car l))
        (else (last (cdr l)))))
(define (make-wire-list n)
  (define (helper nn)
    (if (= nn 0)
        '()
        (cons (make-wire)
              (helper (- nn 1)))))
  (helper n))
 
  ;test
 l-a/l-b/l-s都是低位在左，高位在右。比如(1 0 0)+(1 0 0)=(0 1 0)--0
 (0 0 1)+(0 0 1)=(0 0 0)--1
 
 3.31
 对比两个digital_circuit对下面过程的不同结果：
(define a (make-wire))
(define o (make-wire))
(inverter a o)
(probe 'c-out o)
在未执行(propagate)或者set-signal!之前，本题的the-agenda里面是什么都没有的，而原系统的the-agenda里面时间段为2时已经有了过程。
再上面的基础上执行(set-signal! a 1)，可以看到，这时the-agenda里面才有了过程，但是执行(propagate)却看不到probe过程起作用。只有执行(set-signal! a 1) (set-signal! a 0)这样对a赋值两次以上再执行(propagate)时才能看到probe的结果。

究其原因，make-wire里面的add-action!增加的都是"向the-agenda里面添加过程"的过程，也就是说只有当add-action!增加的过程得到执行的时候，the-agenda中才会添加and-gate/or-gate/inverter等行为，而实际执行这些行为要等到propagate执行的时候。
从数字电路的角度看，原系统在(inverter a o)的时候就已经把相应的导线连好了；而本题的过程直到set-signal!的时候才开始连线，如果想得到相应的结果，只能再set-signal!一次……

3.32
这题比较简单，如果把queue改成类似堆栈的LIFO，就会造成时间上的混乱。比如本题：
(and-gate a b c)
(set-signal! a 0)
(set-signal! b 1)
(propagate)

(set-signal! a 1)
(set-signal! b 0)
(propagate)
第一段执行情况两者一致，最后c都变为0，the-agenda被清空；之后当(set-signal! a 1)时，a和b均为1，the-agenda中加入(set-signal! c 1)，然后(set-signal! b 0)，the-agenda中加入(set-signal! c 0)——不同就在这里产生！本题中由于用了stack结构，使得c=0的语句在c=1之前执行，所以最后就得到了错误结果a=1,b=0,c=1。

;3.27
大体层次结构应该没错的，table在x外层。问题在于为什么不同的x可以共享一个环境中的table。我认为是因为table上一层的环境是(memoize f)的环境，而f一直是memo-fib中的(lambda(n)...)，所以可以共享。
(memo-fib 3)中，3是传递给x的，(lambda(n)...)是传递给f的。之所以时间为O(n)，是因为它不会计算重新以前计算过的值，而只是在table中查找。
至于直接(memoize fib)是不行的，因为memo-fib内部调用的是memo-fib，而这里调用的是fib。

尝试着用这个改写之前计算硬币组合的2.19题：
(define (memorize f)
  (let ((table (make-table)))
    (lambda(x y)
      (let ((pre-result (lookup x y table)))
        (or pre-result
            (let ((result (f x y)))
              (insert! x y result table)
              result))))))
(define memo-cc
  (memorize (lambda (amount coin-values)
              (cond ((= amount 0) 1)
                    ((or (< amount 0)
                         (no-more? coin-values)) 0)
                    (else (+ (memo-cc amount (rest-coins coin-values))
                             (memo-cc (- amount (first-denomination coin-values))
                                      coin-values)))))))
(define (rest-coins x) (cdr x))
(define (no-more? x) (null? x))
(define (first-denomination x) (car x))

与当初2.19里的相比，计算(cc 1000 '(1 5 10 25 50)) 可以感觉到明显的差别。

.;3.26
引入环境模型，出现了许多代换模型中没有的问题，我举两个：
1. 时间因素，set语句的先后的微妙差别会导致错误。估计这一点在后面的"并发"那节会表现的更突出。
2. 相等与共享：a、b的值相同，如果a改变，b随之改变，则两者就是共享的关系；反之只是两者的值相等。由于代换模型中没有赋值改变谁这些事情，也就不需要区分两者——感觉很像C++中的值调用和引用调用——在本题我遇到的麻烦就是这里的。
具体的举个例子：
现有下面过程：
(define (set-to-250! x)  ;这是个无效的过程
  (set! x 250) x)
(define (set-car-250! x)
  (set-car! x 250) x)
(define p1 (cons 1 2))
(define xx (cons p1 p1))

不过(set-car-250! xx)是不会改变xx的值的，它改变的只是内部参数x的值——这对我们毫无用途；我们知道，改变平
的话xx也会随之改变，但是用(set-car-250! xx)却只能改变xx的car，对p1毫无影响。就像是这里的引用是单向的，不对称。

我开始没意识到这些问题，然后就开始打算用赋值语句直接在local-tree上做修改，花了很多时间没有结果。虽然这样的思路肯定是行得通的，但不可否认的是要花很大精力去分辨一些微妙的东西——而且这些东西跟具体语言实现的关系要比跟解题思路的关系还要大。

下面是我对"多维二叉树表"的解决方案——在尽量少的地方使用赋值语句：
;------binary tree------
(define (make-tree left right key value)
  (list left right key value))
(define (make-leaf key value)
  (list '() '() key value))
  
(define (left tree) (car tree))
(define (right tree) (cadr tree))
(define (key tree) (caddr tree))
(define (value tree) (cadddr tree))

(define (tree? x)
  (cond ((null? x) #f)
        ((not (pair? x)) #f)
        ((not (pair? (cdr x))) #f)
        ((not (pair? (cddr x))) #f)
        ((not (pair? (cddr x))) #f)
        ((not (pair? (cdddr x))) #f)
        (else #t)))
(define (set-left! t x)
  (set-car! t x) t)
(define (set-right! t x)
  (set-car! (cdr t) x) t)
(define (set-key! t x)
  (set-car! (cddr t) x) t)
(define (set-value! t x)
  (set-car! (cdddr t) x) t)
;adjoin-list-tree把高一级的节点放在了上层叶节点的value下面
(define (adjoin-list-tree k-l v tree)
  (if (null? (cdr k-l))
      (cond ((null? tree) (make-leaf (car k-l) v))
            ((not (tree? tree)) (make-leaf (car k-l) v))
            ((=? (key tree) (car k-l)) (make-tree (left tree)
                                                  (right tree)
                                                  (key tree)
                                                  v))
            ((<? (car k-l) (key tree)) (make-tree (adjoin-list-tree k-l v (left tree))
                                                  (right tree)
                                                  (key tree)
                                                  (value tree)))
            ((<? (key tree) (car k-l)) (make-tree (left tree)
                                                  (adjoin-list-tree k-l v (right tree))
                                                  (key tree)
                                                  (value tree)))
            (else (error "Unknown situation!" tree)))
      (cond ((null? tree) (make-leaf (car k-l) (adjoin-list-tree (cdr k-l) v '())))
            ((not (tree? tree)) (make-leaf (car k-l) (adjoin-list-tree (cdr k-l) v '())))
            ((=? (car k-l) (key tree)) (make-tree (left tree)
                                                  (right tree)
                                                  (key tree)
                                                  (adjoin-list-tree (cdr k-l) v (value tree))))
            ((<? (car k-l) (key tree)) (make-tree (adjoin-list-tree k-l v (left tree))
                                                  (right tree)
                                                  (key tree)
                                                  (value tree)))
            ((<? (key tree) (car k-l)) (make-tree (left tree)
                                                  (adjoin-list-tree k-l v (right tree))
                                                  (key tree)
                                                  (value tree)))
            (else (error "Unknown situation" tree)))))
(define =?
  (lambda(a b) (= a b)))
(define <?
  (lambda(a b) (< a b)))
;------ make-table----------
(define (make-table same-key?)
  (let ((local-tree (make-tree '() '() '*ROOT* '())))
    (define (lookup key-list)
      (let ((record (assoc-list key-list local-tree)))
        (if (pair? record)
            (value record)
            false)))
    (define (assoc the-key tree)
      (cond ((null? tree) false)
            ((not (tree? tree)) false)
            ((same-key? the-key (key tree)) tree)
            ((< the-key (key tree))
             (assoc the-key (left tree)))
            (else (assoc the-key (right tree)))))
    (define (assoc-list key-list root)   ;这里的root是上层的树
      (if (pair? key-list)
          (let ((subtree (assoc (car key-list) (value root))))
            (if subtree
                (if (null? (cdr key-list))
                    subtree
                    (assoc-list (cdr key-list) subtree))
                false))
          (error "Wrong key-list" key-list)))
     
    (define (insert! key-list val)  ;引用调用的一大陀
      (set-value! local-tree (adjoin-list-tree key-list val (value local-tree))))
     
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "UNKNOWN OPERATION  ----TABLE" m))))
    dispatch))
;test
> (insert! '(1 10) 1000 t1)
(() () *ROOT* (() () 1 (() () 10 1000)))
> (insert! '(1 9) 90 t1)
(() () *ROOT* (() () 1 ((() () 9 90) () 10 1000)))
> (insert! '(1 5) 50 t1)
(() () *ROOT* (() () 1 (((() () 5 50) () 9 90) () 10 1000)))
> (lookup '(1 9) t1)
90
>  (lookup '(1 10) t1)
1000

;3.25
;以下过程是make-table的内部过程
    (define (lookup key-list)
      (let ((record (assoc-list key-list local-table)))
        (if (pair? record)
            (cdr record)
            false)))
    (define (assoc key records)
      (cond ((null? records) false)
            ((not (pair? records)) false)
            ((not (pair? (car records))) false)
            ((same-key? key (caar records)) (car records))
            (else (assoc key (cdr records)))))
    (define (assoc-list key-list table)
      (if (pair? key-list)
          (let ((subtable (assoc (car key-list) (cdr table))))
            (if subtable
                (if (null? (cdr key-list))
                    subtable
                    (assoc-list (cdr key-list) subtable))
                false))
          (error "Wrong key-list" key-list)))
      ;insert-helper!过程每次只插入一个key，然后调用自身——是个迭代过程。
      ;另外一个思路，当k-l的某处发现subtable为假，就直接把剩下的k-l组合好，直接安装过去。这样会快一点。
    (define (insert! key-list value)
      (define (insert-helper! k-l v table)
        (if (pair? k-l)
            (let ((subtable (assoc (car k-l) (cdr table))))
              (if subtable
                  (if (null? (cdr k-l))
                      (set-cdr! subtable v)
                      (insert-helper! (cdr k-l) v subtable))
                  (if (null? (cdr k-l))
                      (set-cdr! table
                                (cons (cons (car k-l) v)
                                      (cdr table)))
                      (begin (set-cdr! table
                                       (cons (list (car k-l))
                                             (cdr table)))
                             (insert-helper! k-l v table)))))
            (error "Wrong key-list" k-l)))
      (insert-helper! key-list value local-table))
     
;test
(insert! '(a a1) 1 t1)
(insert! '(a a1 a2) 20 t1)

> (lookup '(a a1) t1)
((a2 . 20) . 1)
> (lookup '(a a1 a2) t1)
20
> (lookup '(a a1 a3) t1)
#f
----------------------无奈的分割线-----------------
忙活了这么半天，后来在以色列牛那看到，其实有个简单的方法：直接把list作为key，做一个一维的表格就行了，这样只需要写一个表示表格相等的过程就OK了。死脑筋了