计算机程序的构造和解释(SICP) 第4章 习题解析 Part5

这次回顾第四章第五部分习题。

学习资料：

https://ocw.mit.edu/courses/electrical-engineering-and-computer-science/6-001-structure-and-interpretation-of-computer-programs-spring-2005/index.htm

https://github.com/DeathKing/Learning-SICP

https://mitpress.mit.edu/sites/default/files/sicp/index.html

https://www.bilibili.com/video/BV1Xx41117tr?from=search&seid=14983483066585274454

参考资料：

https://sicp.readthedocs.io/en/latest

http://community.schemewiki.org/?SICP-Solutions

http://community.schemewiki.org/?sicp

https://liujiacai.net/blog/2016/02/22/recursion-without-name/

https://mvanier.livejournal.com/2897.html

https://github.com/jiacai2050/sicp

https://liujiacai.net/

4.45(p295)

代码：

(load "ch4-ambeval.scm")

(define the-global-environment (setup-environment))

(driver-loop)

(define (require p)
    (if (not p) (amb)))

(define nouns '(noun student professor cat class))

(define verbs '(verb studies lectures eats sleeps))

(define articles '(article the a))

(define (parse-sentence)
  (list 'sentence
         (parse-noun-phrase)
         (parse-word verbs)))

(define (parse-noun-phrase)
  (list 'noun-phrase
        (parse-word articles)
        (parse-word nouns)))

(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)))

(define *unparsed* '())

(define (parse input)
  (set! *unparsed* input)
  (let ((sent (parse-sentence)))
    (require (null? *unparsed*))
    sent))


;: (parse '(the cat eats))
;; output of parse
; '(sentence (noun-phrase (article the) (noun cat)) (verb eats))

(define prepositions '(prep for to in by with))

(define (parse-prepositional-phrase)
  (list 'prep-phrase
        (parse-word prepositions)
        (parse-noun-phrase)))

(define (parse-sentence)
  (list 'sentence
         (parse-noun-phrase)
         (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)))

(define (parse-simple-noun-phrase)
  (list 'simple-noun-phrase
        (parse-word articles)
        (parse-word nouns)))

(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)))

; test
(parse '(The professor lectures to the student in the class with the cat))

try-again

try-again

try-again

try-again

try-again

实验结果：

;;; Amb-Eval input:
; test
(parse '(The professor lectures to the student in the class with the cat))
;;; Starting a new problem 
;;; Amb-Eval value:
(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)))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(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)))))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(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)))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(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)))))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(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)))))))))

;;; Amb-Eval input:
try-again
;;; There are no more values of
(parse (quote (the professor lectures to the student in the class with the cat)))

4.46(p295)

http://community.schemewiki.org/?sicp-ex-4.46

注意根据parse-word函数的定义，处理unparsed的顺序是从左到右，amb的顺序应该与其对应：

(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)))

4.47(p295)

参考资料：

http://community.schemewiki.org/?sicp-ex-4.47

对4.45的代码进行修改，依然运行

(parse '(The professor lectures to the student in the class with the cat))

发现运行try-again会陷入死循环。

出现这样的原因是因为函数parse-verb-phrase的递归形式如下：

$$A\to A B$$

因为我们的求值器是从左到右求值的，所以结果为

$$A\to AB\to AAB \to \ldots \to A\ldots A B \to \ldots$$

从而会陷入死循环。

如果求值器为从右向左求值，那么结果依然相同。

实验结果：

;;; Amb-Eval input:
; test
(parse '(The professor lectures to the student in the class with the cat))
;;; Starting a new problem 
;;; Amb-Eval value:
(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)))))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(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)))))))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(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)))))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(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)))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(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)))))

;;; Amb-Eval input:
try-again^C
Unhandled signal received.
Killed by SIGQUIT.

4.48(p296)

参考资料：

http://community.schemewiki.org/?sicp-ex-4.48

句子：

名词短语 + 动词短语

名词短语：

简单名词短语 | 名词短语 + 介词短语

动词短语：

简单动词短语 | 动词短语 + 介词短语 | 动词短语 + 副词

简单名词短语：

冠词 + 名词 | 冠词 + 形容词 + 名词

代码：

(load "ch4-ambeval.scm")

(define the-global-environment (setup-environment))

(driver-loop)

(define (require p)
    (if (not p) (amb)))

; 名词
(define nouns '(noun student professor cat class))

; 动词
(define verbs '(verb studies lectures eats sleeps))

; 冠词
(define articles '(article the a))

; 介词
(define prepositions '(prep for to in by with))

; add
; 形容词
(define adjectives '(adjective clever stupid cute))

; 副词
(define adverbs '(adverb absolutely recently))

(define (parse-sentence)
  (list 'sentence
         (parse-noun-phrase)
         (parse-word verbs)))

(define (parse-noun-phrase)
  (list 'noun-phrase
        (parse-word articles)
        (parse-word nouns)))

(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)))

(define *unparsed* '())

(define (parse input)
  (set! *unparsed* input)
  (let ((sent (parse-sentence)))
    (require (null? *unparsed*))
    sent))

(define (parse-prepositional-phrase)
  (list 'prep-phrase
        (parse-word prepositions)
        (parse-noun-phrase)))

(define (parse-sentence)
  (list 'sentence
         (parse-noun-phrase)
         (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)))
         ; add
         (maybe-extend (list 'verb-phrase
                             verb-phrase
                             (parse-word adverbs)))))
  (maybe-extend (parse-word verbs)))

; change
(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))))

; change
(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)))

; test
(parse '(The clever professor lectures recently to the stupid student in the class with the cute cat))

try-again

try-again

try-again

try-again

实验结果：

;;; Amb-Eval input:
; test
(parse '(The clever professor lectures recently to the stupid student in the class with the cute cat))
;;; Starting a new problem 
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (adjective clever) (noun professor)) (verb-phrase (verb-phrase (verb-phrase (verb-phrase (verb lectures) (adverb recently)) (prep-phrase (prep to) (simple-noun-phrase (article the) (adjective stupid) (noun student)))) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class)))) (prep-phrase (prep with) (simple-noun-phrase (article the) (adjective cute) (noun cat)))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (adjective clever) (noun professor)) (verb-phrase (verb-phrase (verb-phrase (verb lectures) (adverb recently)) (prep-phrase (prep to) (simple-noun-phrase (article the) (adjective stupid) (noun student)))) (prep-phrase (prep in) (noun-phrase (simple-noun-phrase (article the) (noun class)) (prep-phrase (prep with) (simple-noun-phrase (article the) (adjective cute) (noun cat)))))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (adjective clever) (noun professor)) (verb-phrase (verb-phrase (verb-phrase (verb lectures) (adverb recently)) (prep-phrase (prep to) (noun-phrase (simple-noun-phrase (article the) (adjective stupid) (noun student)) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class)))))) (prep-phrase (prep with) (simple-noun-phrase (article the) (adjective cute) (noun cat)))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (adjective clever) (noun professor)) (verb-phrase (verb-phrase (verb lectures) (adverb recently)) (prep-phrase (prep to) (noun-phrase (noun-phrase (simple-noun-phrase (article the) (adjective stupid) (noun student)) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class)))) (prep-phrase (prep with) (simple-noun-phrase (article the) (adjective cute) (noun cat)))))))

;;; Amb-Eval input:
try-again
End of input stream reached.
Moriturus te saluto.

4.49(p296)

代码：

(load "ch4-ambeval.scm")

(define the-global-environment (setup-environment))

(driver-loop)

(define (require p)
    (if (not p) (amb)))

(define nouns '(noun student professor cat class))

(define verbs '(verb studies lectures eats sleeps))

(define articles '(article the a))

; change
(define (parse-word word-list)
  (require (not (null? (cdr word-list))))
  (let ((found-word (car (cdr (word-list)))))
    (set! word-list (cons (car word-list) (cdr (cdr (word-list)))))
    (list (car word-list) found-word)))

; 对数组使用amb, 枚举其中的值
(define (amb-list arr)
    (if (null? arr)
        (amb)
        (amb (car arr) (amb-list (cdr arr)))))

(define (parse-word word-list)
    (require (not (null? *unparsed*)))
    (let ((words (cdr word-list)))
         (require (not (null? words)))
         (let ((found-word (amb-list words)))
            (set! word-list (cons (car word-list) (cdr words)))
            (set! *unparsed* (cdr *unparsed*))
            (list (car word-list) found-word))))

(define *unparsed* '())

; add
; (sentence (simple-noun-phrase (article the) (adjective clever) (noun professor)) -> the clever professor
(define (get-sentence sent)
    (if (not (pair? (cadr sent)))
        (cdr sent)
        (append (get-sentence (cadr sent))
                  (get-sentence (caddr sent)))))

; change
(define (parse input)
  (set! *unparsed* input)
  (let ((sent (parse-sentence)))
    (require (null? *unparsed*))
    (get-sentence sent)))

(define prepositions '(prep for to in by with))

(define (parse-prepositional-phrase)
  (list 'prep-phrase
        (parse-word prepositions)
        (parse-noun-phrase)))

(define (parse-sentence)
  (list 'sentence
         (parse-noun-phrase)
         (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)))

(define (parse-simple-noun-phrase)
  (list 'simple-noun-phrase
        (parse-word articles)
        (parse-word nouns)))

(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)))

; test
(parse '(The professor lectures to the student in the class with the cat))

try-again

try-again

try-again

try-again

try-again

try-again

实验结果：

;;; Amb-Eval input:
; test
(parse '(The professor lectures to the student in the class with the cat))
;;; Starting a new problem 
;;; Amb-Eval value:
(the student studies for the student for the student for the student)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(the student studies for the student for the student for the professor)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(the student studies for the student for the student for the cat)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(the student studies for the student for the student for the class)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(the student studies for the student for the student for a student)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(the student studies for the student for the student for a professor)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(the student studies for the student for the student for a cat)

;;; Amb-Eval input:
End of input stream reached.
Moriturus te saluto.

这种方法生成的句子是按照字典序产生的，生成的结果没有随机性。

4.50(p303)

修改che-ambeval.scm中的函数analyze-amb：

; ramb
; add
(define (get-random-index arr)
    (if (null? arr)
        0
        (random (length arr))))

(define (get-ith-element arr i)
    (if (= i 0)
        (car arr)
        (get-ith-element (cdr arr) (- i 1))))

(define (rm-ith-element arr i)
    (define (rm-iter res cur-arr j)
        (if (= j i)
            (append res (cdr cur-arr))
            (rm-iter (append res (list (car cur-arr))) (cdr cur-arr) (+ j 1))))
    (rm-iter '() arr 0))

(define (analyze-amb exp)
  (let ((cprocs (map analyze (amb-choices exp))))
    (lambda (env succeed fail)
      (define (try-next choices)
        (let ((i (get-random-index choices)))
            (if (null? choices)
                (fail)
                ((get-ith-element choices i) env
                        succeed
                        (lambda ()
                            (try-next (rm-ith-element choices i)))))))
      (try-next cprocs))))

结果：

;;; Amb-Eval input:
; test
(parse '(The professor lectures to the student in the class with the cat))
;;; Starting a new problem 
;;; Amb-Eval value:
(the student studies for the class with the class by the cat)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(the student studies for the class with the class by the class)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(the student studies for the class with the class by the professor)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(the student studies for the class with the class by the student)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(the student studies for the class with the class by a student)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(the student studies for the class with the class by a cat)

;;; Amb-Eval input:
try-again
End of input stream reached.
Moriturus te saluto.

这种方法生成的结果有随机性。

4.51(p303)

修改che-ambeval.scm中的函数analyze函数，在cond中增加如下内容：

; 4.51 add before application
((permanent-assignment? exp) (analyze-permanent-assignment exp))

在che-ambeval.scm中增加如下函数：

; 4.51 add
(define (permanent-assignment? exp)
  (tagged-list? exp 'permanent-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))))
; end

代码：

(load "ch4-ambeval.scm")

(define the-global-environment (setup-environment))

(driver-loop)

(define (require p)
    (if (not p) (amb)))

(define count 0)

(define (get-ith-element arr i)
    (if (= i 0)
        (car arr)
        (get-ith-element (cdr arr) (- i 1))))

(define (an-element-of items)
  (require (not (null? items)))
  (amb (car items) (an-element-of (cdr items))))

(let ((x (an-element-of '(a b c)))
      (y (an-element-of '(a b c))))
  (set! count (+ count 1))
  (require (not (eq? x y)))
  (list x y count))

; (let ((x (an-element-of '(a b c)))
;       (y (an-element-of '(a b c))))
;   (permanent-set! count (+ count 1))
;   (require (not (eq? x y)))
;   (list x y count))

try-again

try-again

set!结果：

;;; Amb-Eval input:
(let ((x (an-element-of '(a b c)))
      (y (an-element-of '(a b c))))
  (set! count (+ count 1))
  (require (not (eq? x y)))
  (list x y count))
;;; Starting a new problem 
;;; Amb-Eval value:
(a b 1)

;;; Amb-Eval input:
; (let ((x (an-element-of '(a b c)))
;       (y (an-element-of '(a b c))))
;   (permanent-set! count (+ count 1))
;   (require (not (eq? x y)))
;   (list x y count))

try-again
;;; Amb-Eval value:
(a c 1)

;;; Amb-Eval input:
try-again
End of input stream reached.
Moriturus te saluto.

permanent-set!结果：

;;; Amb-Eval input:
; (let ((x (an-element-of '(a b c)))
;       (y (an-element-of '(a b c))))
;   (set! count (+ count 1))
;   (require (not (eq? x y)))
;   (list x y count))

(let ((x (an-element-of '(a b c)))
      (y (an-element-of '(a b c))))
  (permanent-set! count (+ count 1))
  (require (not (eq? x y)))
  (list x y count))
;;; Starting a new problem 
;;; Amb-Eval value:
(a b 2)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(a c 3)

;;; Amb-Eval input:
try-again
End of input stream reached.
Moriturus te saluto.

4.52(p303)

参考资料：

http://community.schemewiki.org/?sicp-ex-4.52

默认调用proc1，成功了则继续调用succeed；如果失败则调用proc2。

修改che-ambeval.scm中的函数analyze函数，在cond中增加如下内容：

; 4.52 add before application
((if-fail? exp) (analyze-if-fail exp))

在che-ambeval.scm中增加如下函数：

; 4.52 add
(define (if-fail? exp)
  (tagged-list? exp 'if-fail))

(define (if-fail-proc1 exp)
  (cadr exp))

(define (if-fail-proc2 exp)
  (caddr exp))

(define (analyze-if-fail exp)
  (let ((proc1 (analyze (if-fail-proc1 exp)))
        (proc2 (analyze (if-fail-proc2 exp))))
    (lambda (env succeed fail)
      (proc1 env
             succeed
             (lambda ()
                   (proc2 env succeed fail))))))
; end

代码：

(load "ch4-ambeval.scm")

(define the-global-environment (setup-environment))

(driver-loop)

(define (require p)
    (if (not p) (amb)))

(define (an-element-of items)
  (require (not (null? items)))
  (amb (car items) (an-element-of (cdr items))))

(define (even? x)
  (if (= (remainder x 2) 1)
    false
    true))

(if-fail (let ((x (an-element-of '(1 3 5))))
           (require (even? x))
           x)
         'all-odd)

(if-fail (let ((x (an-element-of '(1 3 5 8))))
           (require (even? x))
           x)
         'all-odd)

实验结果：

;;; Amb-Eval input:
(if-fail (let ((x (an-element-of '(1 3 5))))
           (require (even? x))
           x)
         'all-odd)
;;; Starting a new problem 
;;; Amb-Eval value:
all-odd

;;; Amb-Eval input:
(if-fail (let ((x (an-element-of '(1 3 5 8))))
           (require (even? x))
           x)
         'all-odd)
;;; Starting a new problem 
;;; Amb-Eval value:
8

;;; Amb-Eval input:
End of input stream reached.
Moriturus te saluto.

4.53(p304)

代码：

(load "ch4-ambeval.scm")

(define the-global-environment (setup-environment))

(driver-loop)

(define (require p)
    (if (not p) (amb)))

(define (an-element-of items)
  (require (not (null? items)))
  (amb (car items) (an-element-of (cdr items))))


; prime?
(define (find-divisor n test-divisor)
  (cond ((> (* test-divisor test-divisor) n) n)
        ((= (remainder n test-divisor) 0) test-divisor)
        (else (find-divisor n (+ test-divisor 1)))))

(define (smallest-divisor n)
    (find-divisor n 2))

(define (prime? n)
    (= n (smallest-divisor n)))

(define (prime-sum-pair list1 list2)
  (let ((a (an-element-of list1))
        (b (an-element-of list2)))
    (require (prime? (+ a b)))
    (list a b)))

(let ((pairs '()))
  (if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
             (permanent-set! pairs (cons p pairs))
             (amb))
           pairs))

(let ((pairs '()))
  (if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
             (set! pairs (cons p pairs))
             (amb))
           pairs))

实验结果：

;;; Amb-Eval input:
(let ((pairs '()))
  (if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
             (permanent-set! pairs (cons p pairs))
             (amb))
           pairs))
;;; Starting a new problem 
;;; Amb-Eval value:
((8 35) (3 110) (3 20))

;;; Amb-Eval input:
(let ((pairs '()))
  (if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
             (set! pairs (cons p pairs))
             (amb))
           pairs))
;;; Starting a new problem 
;;; Amb-Eval value:
()

;;; Amb-Eval input:
End of input stream reached.
Moriturus te saluto.

4.54(p304)

参考资料：

http://community.schemewiki.org/?sicp-ex-4.54

修改che-ambeval.scm中的函数analyze函数，在cond中增加如下内容：

; 4.54 add before application
((require? exp) (analyze-require exp))

在che-ambeval.scm中增加如下函数：

; 4.54 add
(define (require? exp) (tagged-list? exp 'require))

(define (require-predicate exp) (cadr exp))

(define (analyze-require exp)
  (let ((pproc (analyze (require-predicate exp))))
    (lambda (env succeed fail)
      (pproc env
             (lambda (pred-value fail2)
                (if (not pred-value)
                    (fail2)
                    (succeed 'ok fail2)))
             fail))))
; end

代码：

(load "ch4-ambeval.scm")

(define the-global-environment (setup-environment))

(driver-loop)

(define (an-element-of items)
  (require (not (null? items)))
  (amb (car items) (an-element-of (cdr items))))

; prime?
(define (find-divisor n test-divisor)
  (cond ((> (* test-divisor test-divisor) n) n)
        ((= (remainder n test-divisor) 0) test-divisor)
        (else (find-divisor n (+ test-divisor 1)))))

(define (smallest-divisor n)
    (find-divisor n 2))

(define (prime? n)
    (= n (smallest-divisor n)))

(define (prime-sum-pair list1 list2)
  (let ((a (an-element-of list1))
        (b (an-element-of list2)))
    (require (prime? (+ a b)))
    (list a b)))

(let ((pairs '()))
  (if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
             (permanent-set! pairs (cons p pairs))
             (amb))
           pairs))

实验结果：

;;; Amb-Eval input:
(define (prime-sum-pair list1 list2)
  (let ((a (an-element-of list1))
        (b (an-element-of list2)))
    (require (prime? (+ a b)))
    (list a b)))
;;; Starting a new problem 
;;; Amb-Eval value:
ok

;;; Amb-Eval input:
(let ((pairs '()))
  (if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
             (permanent-set! pairs (cons p pairs))
             (amb))
           pairs))
;;; Starting a new problem 
;;; Amb-Eval value:
((8 35) (3 110) (3 20))

;;; Amb-Eval input:
End of input stream reached.
Moriturus te saluto.