ch04 元语言抽象 part03
Scheme的变形——非确定性计算
这一节里，通过给求值器增加「自动搜索」的功能，来让求值器支持「非确定性计算」 的程序设计范式。
非确定性计算与流处理类似，都很适合处理「生成和检测」这一类问题。 在2.2.3节和3.5.3节分别使用序列操作和流过滤的方式从两个序列里找出各为素数的序对。 非确定性方式提供了另一种实现方式：设想以某种方式从第一个表里取出一个数， 再用相同的方式从第二个表里取一个数，全它们的和是素数。这样的算法可以描述为：
(define (prime-sum-pair list1 list2)
(let ((a (an-element-of list1))
(b (an-element-of list2)))
(require (prime? (+ a b)))
(list a b)))
以上的代码看起来只是描述了「问题是什么」，而没有描述「问题的解决方案」， 但这就是一个合法的非确定性程序。
非确定性程序的主要思想是：类似于分裂为多个平行宇宙，一个表达式有多个可能的值， 从中选一个可能性保持执行轨迹，如果不符合就再选另一个， 直到求值成功或是用光所有的可能性。
本节所要实现的求值器名叫「amb」，因为它是基于称为amb的新特殊形式。例如，
之前的prime-sum-pair传递给求值器的驱动循环，会有以下执行过程：
;;; Amb-Eval input: (prime-sum-pair '(1 3 5 8) '(20 35 110)) ;;; Starting a new problem ;;; Amb-Eval value: (3 20)
abm和搜索
这里引入特殊形式amb，它不是过程，是一种特殊形式：
(amb <e1> <e2> ... <en>)
amb会返回\(n\)个表达式中其中的一个\(e_i\)的值；如果没有一个满足条件，
就不会产生任何值。
根据这一思想，可以把某个特定谓词必须为真的要求表述为：
(define (require p) (if (not p) (amb)))
有了amb和require，就可以实现an-element-of过程：
(define (an-element-of items) (require (not (null? items))) (amb (car items) (an-element-of (cdr items))))
这样就可以从有限的元素中（有歧义地）返回一个元素或是失败。
这样的机制还可以用在无限的元素中，例如返回大于\(n\)的整数：
(define (an-integer-starting-from n) (amb n (an-integer-starting-from (+ n 1))))
注意amb与流的区别：
- 流返回的是一个「对象」，代表从\(n\)开始的整数序列。
-
amb返回的就是一个整数。
驱动循环
amb的驱动循环和一般的驱动循环不一样。读入表达式并输出一个值以后，要求另一个值，
可以输入try-again要求表达式回溯，尝试示出第另一个符合条件的值。当没有值时，
会开始一个新的问题。例如：
;;; Amb-Eval input: (prime-sum-pair '(1 3 5 8) '(20 35 110)) ;;; Starting a new problem ;;; Amb-Eval value: (3 20) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (3 110) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (8 35) ;;; Amb-Eval input: try-again ;;; There are no more values of (prime-sum-pair (quote (1 3 5 8)) (quote (20 35 110))) ;;; Amb-Eval input: (prime-sum-pair '(19 27 30) '(11 36 58)) ;;; Starting a new problem ;;; Amb-Eval value: (30 11)
练习 4.35
写出一个过程an-integer-between，它返回两个限界之间的整数。
用来实现毕达哥拉斯三元组的过程。即：
对于\((i, j, k)\)，使得\(i \leq j\)并且\(i^2+j^2=k^2\)。
程序的其他部分如下：
(define (a-pythagorean-triple-between low high)
(let ((i (an-integer-between low high)))
(let ((j (an-integer-between i high)))
(let ((k (an-integer-between j high)))
(require (= (+ (* i i) (* j j)) (* k k)))
(list i j k)))))
解：
(define (an-integer-between a b)
(require (<= a b))
(amb a (an-integer-between (+ a 1) b)))
;; low <= i <= j <= k <= high
(define (a-pythagorean-triple-between low high)
(let* ((i (an-integer-between low high))
(j (an-integer-between i high))
(k (an-integer-between j high)))
(require (= (+ (* i i) (* j j) (* k k))))
(list i j k)))
练习 4.36
为什么简单地用练习3.69中的an-integer-starting-from代替练习4.35中过程
an-integer-between不是合适的办法？请写出一个确实能完成这一工作的过程。
比如说当\(i = 4, j = 5\)的情况下，没有能够满足条件的\(k\)，如果使用流，
会导致try-again不断给出新的不满足的\(k\)，因此无法得出结果。
;; low <= k <= j <= i < infinite
(define (a-pythagorean-triple-from low)
(let* ((i (an-integer-starting-from low)) ; "high" is infinite
(j (an-integer-between low i))
(k (an-integer-between low j)))
(require (= (+ (* i i) (* j j) (* k k))))
(list i j k)))
练习 4.37
以下程序生成的毕达哥斯拉三元组是否比练习4.35中更加高效？
(define (a-pythagorean-triple-between low high)
(let ((i (an-integer-between low high))
(hsq (* high high)))
(let ((j (an-integer-between i high)))
(let ((ksq (+ (* i i) (* j j))))
(require (>= hsq ksq))
(let ((k (sqrt ksq)))
(require (integer? k))
(list i j k))))))
如果是要枚举[low, high]区间的所有毕达哥拉斯三元组，那么这个作法的确更快了，
把时间复杂度从\(O(N^3)\)下降到\(O(N^2)\)。
对于单次调用而言则有可能出现后者更慢（例如3,4,5）。
非确定性程序实例
虽然我们还没有实现amb过程，但可以先通过几个例子来了解一下非确定程序设计的优点
：更高的抽象层次。
比如有一个简单的逻辑题，求5个人分别在哪一楼：
- Baker、Cooper、Fletcher、Miller、Smith他们5个人住在某5层楼的不同楼层。
- Baker不在顶层。
- Cooper不在底层。
- Fletcher不在顶层也不在底层。
- Miller比Cooker高一层。
- Smith和Fletcher不相邻。
- Fletcher和Cooper不相邻。
(define (multiple-dwelling)
(let ((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
(distinct? (list baker cooper fletcher miller smith)))
(require (not (= baker 5)))
(require (not (= cooper 1)))
(require (not (= fletcher 5)))
(require (not (= fletcher 1)))
(require (> miller cooper))
(require (not (= (abs (- smith fletcher)) 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith))))
程序用以distinct?过程确定表里的元素是否互不相同：
(define (distinct? items)
(cond ((null? items) true)
((null? (cdr items)) true)
((member (car items) (cdr items)) false)
(else (distinct? (cdr items)))))
member与memq类似，只是用equal?做相等判断，而不是eq?。
执行multiple-dwelling就可以得到迷题的答案：
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
但是执行的时间非常长，在练习4.39和4.40讨论如何改进。
练习 4.38
如果修改题目，去掉Smith和Fletcher相邻这个条件，这个迷题会有多少个解？
中文书翻译错误。
答案有5个：
[1, 2, 4, 3, 5] [1, 2, 4, 5, 3] [1, 4, 2, 5, 3] [3, 2, 4, 5, 1] [3, 4, 2, 5, 1]
练习 4.39
调整条件的顺序是否会影响程序速度？
不影响答案也不影响时间复杂度:
无论约束条件如何修改，它仍然是\(O(n)\)复杂度， 每一个可能的组合都需要通过这些约束条件的检验，直到找到第一个符合条件的组合。
但是在常数时间优化上，把否定概率高的条件放在最前面可以提高些微效率。
UPDATE:
meteorgan认为, 由于distinct?的实现不是\(O(1)\)的，而是跟人数\(m\)成\(O(m)\)的关系，
所以把它放在最后能减少所需时间。
使用如下Python代码测试，的确能快不少。
def distinct(*args):
return len(set(args)) == len(args)
from itertools import product
for i in range(1000):
for b, c, f, m, s in product([1, 2, 3, 4 ,5], repeat=5):
#if not distinct(b, c, f, m, s): continue
if b == 5: continue
if c == 1: continue
if f == 5: continue
if f == 1: continue
if m <= c: continue
if abs(s - f) == 1: continue
if abs(f - c) == 1: continue
if not distinct(b, c, f, m, s): continue
print [b, c, f, m, s]
练习 4.40
如果遍历所有的组合可能性，会有多少种组合？对所有组合回溯效率太低， 请实现一个不生成已经被排除的组合的算法。（提示：需要写出嵌套的let表达式）
;; The use of 'an-integer-between' helps a lot here.
(define (multiple-dwelling)
(let* ((baker (amb 1 2 3 4))
(cooper (amb 2 3 4 5))
(fletcher (amb 2 3 4)))
(require (not (= (abs (- fletcher cooper)) 1)))
(let* ((miller (an-integer-between (+ 1 cooper) 5))
(smith (amb
(an-integer-between (1 (- fletcher 2)))
(an-integer-between (+ fletcher 2) 5))))
(require
(distinct? (list baker cooper fletcher miller smith)))
(list
(list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))))
练习 4.41
用一个常规Scheme程序解决多楼层问题。
我的解决方案：
(include "4.3.2-common.scm")
; baker cooper fletcher miller smith
(define (multiple-dwelling)
(define (iter try n)
(if (> n 0)
(letrec ((test (lambda (i)
(iter (cons i try) (- n 1))
(if (< i 5)
(test (+ i 1))))))
(test 1))
(if (and (distinct? try)
(apply (lambda (baker cooper fletcher miller smith)
(and (!= baker 5)
(!= cooper 1)
(!= fletcher 1)
(!= fletcher 5)
(> miller cooper)
(!= (abs (- smith fletcher)) 1)
(!= (abs (- fletcher cooper)) 1)))
try))
(begin
(display
(map (lambda (x y) (list x y))
(list 'baker 'cooper 'fletcher 'miller 'smith)
try))
(newline)))))
(iter '() 5))
更好的解决方法：
(define (multiple-dwelling)
(for-each
(lambda (try)
(apply
(lambda (baker cooper fletcher miller smith)
(if (and (!= baker 5)
(!= cooper 1)
(!= fletcher 1)
(!= fletcher 5)
(> miller cooper)
(!= (abs (- smith fletcher)) 1)
(!= (abs (- fletcher cooper)) 1))
(display (list baker cooper fletcher miller smith))))
try))
(permutations '(1 2 3 4 5))))
(multiple-dwelling)
练习 4.42
五个姑娘每个人都要说一句真话和一句假话。其中部分的句子：
- Betty：Kitty考第二，我考第三。
- Ethel：我第一，Joan第二。
- Joan：我第二，Ethel最差。
- Kitty：我第二，Marry第四。
- Mary：我第四，Betty第一。
求真实成绩。
(include "4.3.2-common.scm")
(define (true-false a b)
(or
(and a (not b))
(and (not a) b)))
amb版本：
(define (require-a-b a b)
(require (true-false a b)))
(define (liar)
(let ((betty (an-integer-between 1 5))
(ethel (an-integer-between 1 5))
(joan (an-integer-between 1 5))
(kitty (an-integer-between 1 5))
(mary (an-integer-between 1 5)))
(require-a-b (= kitty 2) (= betty 3))
(require-a-b (= ethel 1) (= joan 2))
(require-a-b (= joan 3) (= ethel 5))
(require-a-b (= kitty 2) (= mary 4))
(require-a-b (= mary 4) (= betty 1))
(let ((try (list 'betty ethel joan kitty mary)))
(require (distinct? try))
try)))
普通程序版本：
(define (liar)
(for-each
(lambda (try)
(apply
(lambda (betty ethel joan kitty mary)
(if (and
(true-false (= kitty 2) (= betty 3))
(true-false (= ethel 1) (= joan 2))
(true-false (= joan 3) (= ethel 5))
(true-false (= kitty 2) (= mary 4))
(true-false (= mary 4) (= betty 1)))
(display try)))
try))
(permutations '(1 2 3 4 5))))
(liar)
练习 4.43
Marry Ann Moore的父亲有船。父亲的四个朋友Colonel Downing、Mr. Hall、Sir Barnacle Hood和Dr. Parker也有船和女儿。他们用另一个人的女儿的名字给船起名：
- Mr. Moore的船是：Lorna
- Colonel Downing的船是：Melissa（是Sir Barnacle女儿的名字）
- Mr. Hall的船是：Rosalind
- Sir Barnacle Hood的船是：Gabrielle
- Gabrielle父亲的船是用Dr. Parker女儿的名字。
请问谁是Lorna的父亲？
(include "4.3.2-common.scm")
(define all-fathers (list 'Moore 'Downing 'Hall 'Barnacle 'Parker))
(define all-daughters (list 'Mary 'Gabrelle 'Lorna 'Rosalind 'Melissa))
;; copied from http://community.schemewiki.org/?sicp-ex-4.43
;; BOATS:
;; Moore - Lorna
;; Barnacle - Gabrielle
;; Hall - Rosalind
;; Downing - Melissa
;; Parker - Mary
(define (father-daughter)
(let ((Moore 'Mary)
(Barnacle 'Melissa)
(Hall (amb 'Gabrelle 'Lorna))
(Downing (amb 'Gabrelle 'Lorna 'Rosalind))
(Parker (amb 'Lorna 'Rosalind)))
; └> The name of Gabrielle's Father's Boat is Parker's daughter's name,
; so Parker's daughter won't be Gabrielle.
(require
; The name of Gabrielle's Father's Boat is Parker's daughter's name
(cond
((eq? Hall 'Gabrelle) (eq? 'Rosalind Parker)) ;Hall's boat's name is Rosalind
((eq? Downing 'Gabrelle) (eq? 'Melissa Parker)) ;Downing's boat's name is Melissa
(else false)))
(require (distinct? (list Moore Barnacle Hall Downing Parker)))
(list
(list 'Barnacle Barnacle)
(list 'Moore Moore)
(list 'Hall Hall)
(list 'Downing Downing)
(list 'Parker Parker))))
(father-daughter)
ANSWER:
(Moore Mary) (Barnacle Melissa) (Hall Gabrelle) (Downing Lorna) (Parker Rosalind)
如果不知道Moore的女儿是Mary, 会多一个答案：
(Moore Gabrelle) (Barnacle Melissa) (Hall Mary) (Downing Rosalind) (Parker Lorna)
(define (father-daughter)
(let ((Moore (amb 'Mary 'Gabrelle 'Rosalind ))
(Barnacle 'Melissa)
(Hall (amb 'Gabrelle 'Lorna))
(Downing (amb 'Gabrelle 'Lorna 'Rosalind))
(Parker (amb 'Lorna 'Rosalind)))
; └> The name of Gabrielle's Father's Boat is Parker's daughter's name,
; so Parker's daughter won't be Gabrielle.
(require
; The name of Gabrielle's Father's Boat is Parker's daughter's name
(cond
((eq? Moore 'Gabrelle) (eq? 'Lorna Parker)) ;Moore's boat's name is Lorna
((eq? Hall 'Gabrelle) (eq? 'Rosalind Parker)) ;Hall's boat's name is Rosalind
((eq? Downing 'Gabrelle) (eq? 'Melissa Parker)) ;Downing's boat's name is Melissa
(else false)))
(require (distinct? (list Moore Barnacle Hall Downing Parker)))
(list
(list 'Barnacle Barnacle)
(list 'Moore Moore)
(list 'Hall Hall)
(list 'Downing Downing)
(list 'Parker Parker))))
python代码：
#!/usr/bin/env python
#coding:utf-8
import itertools
fathers = ['Moore', 'Barnacle', 'Hall', 'Downing', 'Parker']
daughters = ['Mary', 'Gabrelle', 'Lorna', 'Rosalind', 'Melissa']
boats = ['Lorna', 'Gabrielle', 'Rosalind', 'Melissa', 'Mary']
boat_map = dict(zip(fathers, boats))
for seq in itertools.permutations(daughters):
daughter_map = dict(zip(fathers, seq))
father_map = dict(zip(seq, fathers))
#if daughter_map['Moore'] != 'Mary': continue
if daughter_map['Barnacle'] != 'Melissa': continue
for f, b in zip(fathers, boats):
if daughter_map[f] == b:
break
else:
if boat_map[father_map['Gabrelle']] == daughter_map['Parker']:
print zip(fathers, seq)
练习 4.44
用非确定性程序解八皇后问题：
(include "4.3.2-common.scm")
(define (safe? solution) ;;copied from queen.scm
(let ((p (car solution)))
(define (conflict? q i)
(or
(= p q)
(= p (+ q i))
(= p (- q i))))
(define (check rest i)
(cond
((null? rest) #t)
((conflict? (car rest) i) #f)
(else (check (cdr rest) (inc i)))))
(check (cdr solution) 1)))
(define (queens n)
(define (iter solution n-left)
(if (= n-left 0)
(begin
(display solution)
(newline))
(begin
(let ((x-solution (cons (an-integer-between 1 n) solution)))
(require (safe? x-solution))
(iter x-solution (- n-left 1))))))
(iter '() n))
(queens 8)
自然语言语法分析
从最简单的形式入手：「The cat eats」
单词分类：「冠词」跟「名词」跟「动词」。
(define articles '(article the a)) (define nouns '(noun student professor cat class)) (define verbs '(verb studies lectures eats sleeps))
语法分析：
- 名词短语后跟着一个动词。
- 名词短语是由冠词后跟名词组成。
(sentence (noun-phrase (article the) (noun cat))
(verb eats))
所以分析句子的程序要返回「名词短语」和「动词」两部分，数据抽象上用表来实现，
表的第一个元素是sentence来表示这是一个句子：
(define (parse-sentence)
(list 'sentence
(parse-noun-phrase)
(parse-word verbs)))
分析名词短语的程序也是以表作为返回值，表头用noum-pahrase，后面是冠词和名词：
(define (parse-noun-phrase)
(list 'noun-phrase
(parse-word articles)
(parse-word nouns))
最底层的的分析过程归纳为反复检查下一个还没有分析的单词是不是所期待的单词类型。
为了实现这个目标，需要维护一个全局变量*unparsed*，值为尚未分析的输入。
每当程序检查一个单词，都要检查它不能为空，而且要在指定的表里的单词开始。
如果符合以上要求，就从*unparsed*里删除这第一个单词，并返回这个单词和它的类型：
(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))) ;; 分类表中第一个元素（即类型）与单词
为了做语法分析，要把*unparsed*设置为整个输入，尝试分析一个句子出来，
最后还有检查有没有剩下任何东西：
(define *unparsed* '())
(define (parse input)
(set! *unparsed* input)
(let ((sent (parse-sentence))) ;; 把解析后的结果作赋值给sent
(require (null? *unparsed*)) ;; 解析完后*unparsed*中不能有任何内容
sent)) ;; 这样sent才是符合的结果
测试一下能不能用：
;;; Amb-Eval input: (parse '(the cat eats)) ;;; Starting a new problem ;;; Amb-Eval value: (sentence (noun-phrase (article the) (noun cat)) (verb eats))
更一步完善，增加「介词」：
(define prepositions '(prep for to in by with))
处理介词短语，如「for the cat」：
(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)))
在此基础上还可以细化名词短语的定义，如：「a cat in the class」。 为了方便区别，之前叫作「名词短语」的片段现在改叫「简单名词短语」， 现在的「名词短语」指的是一个简单名词短语或是一个名词短语后面跟一个介词短语：
(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)))
新语法可以分析更加复杂的句子，例如：
(parse '(the student with the cat sleeps in the class))
结果为：
(sentence
(noun-phrase
(simple-noun-phrase (article the) (noun student))
(prep-phrase (prep with)
(simple-noun-phrase
(article the) (noun cat))))
(verb-phrase
(verb sleeps)
(prep-phrase (prep in)
(simple-noun-phrase
(article the) (noun class)))))
有时候同一个输入会有多个可能的结果。例如：
(parse '(the professor lectures to the student with the 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 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 with)
(simple-noun-phrase
(article the) (noun cat)))))))
练习 4.45
「the professor lectures to the student with the cat」有5种分析方式
;;; Amb-Eval input:
(parse '(the professor lectures to the student in the class with the cat))
;;; Starting a new problem
;;; Amb-Eval output:
(sentence
(noun-phrase (articles the) (nouns professor))
(verb-phrase (verb-phrase
(verb-phrase (verb lectures)
(pre-phrase (prep to) (noun-phrase (articles the) (nouns student))))
(pre-phrase (prep in) (noun-phrase (articles the) (nouns class))))
(pre-phrase (prep with) (noun-phrase (articles the) (nouns cat)))))
;;; Amb-Eval input:
try-again
;;; Amb-Eval output:
(sentence (noun-phrase (articles the) (nouns professor))
(verb-phrase (verb-phrase (verb lectures)
(pre-phrase (prep to)
(noun-phrase (articles the)
(nouns student))))
(pre-phrase (prep in)
(noun-phrase (noun-phrase (articles the) (nouns class))
(pre-phrase (prep with)
(noun-phrase (articles the) (nouns cat)))))))
;;; Amb-Eval input:
try-again
;;; Amb-Eval output:
(sentence (noun-phrase (articles the) (nouns professor))
(verb-phrase (verb-phrase (verb lectures)
(pre-phrase (prep to)
(noun-phrase (noun-phrase (articles the) (nouns student))
(pre-phrase (prep in)
(noun-phrase (articles the) (nouns class))))))
(pre-phrase (prep with) (noun-phrase (articles the) (nouns cat)))))
;;; Amb-Eval input:
try-again
;;; Amb-Eval output:
(sentence (noun-phrase (articles the) (nouns professor))
(verb-phrase (verb lectures)
(pre-phrase (prep to)
(noun-phrase (noun-phrase (noun-phrase (articles the)
(nouns student))
(pre-phrase (prep in)
(noun-phrase (articles the)
(nouns class))))
(pre-phrase (prep with) (noun-phrase (articles the) (nouns cat)))))))
;;; Amb-Eval input:
try-again
;;; Amb-Eval output:
(sentence (noun-phrase (articles the) (nouns professor))
(verb-phrase (verb lectures)
(pre-phrase (prep to)
(noun-phrase (noun-phrase (articles the)
(nouns student))
(pre-phrase (prep in)
(noun-phrase (noun-phrase (articles the)
(nouns class))
(pre-phrase (prep with)
(noun-phrase (articles the)
(nouns cat)))))))))
练习 4.46 求值顺序
目前amb采用的是从左到右的求值顺序，如果用别的顺序就不能工作了。请分析原因。
因为程序parse-word以从左到右的顺序来处理*unparsed*，amb不能与它相冲突。
练习 4.47
对于「动词短语或是一个动词」或「动词短语后跟一个介词短语」是否可以直接定义：
(define (parse-verb-phrase)
(amb (parse-word verbs)
(list 'verb-phrase
(parse-verb-phrase)
(parse-prepositional-phrase))))
如果amb求值器的顺序改变了，程序的行为也会改变么？
parse-verb-phrase不能工作，因为第二个分枝会再次调用(parse-verb-phrase)，
引起无穷循环。
就算改变了amb的求值顺序，也一样会无穷循环。
练习 4.48 继续扩充语法
继续扩充语法，给名词和动词短语加上形容词和副词，或处理复合句 （但由于语法在很多情况下是高度递归的，所以会有递归陷阱。 练习 4.50讨论了部分解决方法）。
(define adjectives '(adjective ugly stupid lazy dirty shitty))
(define (parse-simple-noun-phrase)
(amb (list 'simple-noun-phrase
(parse-word articles)
(parse-word nouns))
(list 'simple-noun-phrase
(parse-word articles)
(parse-word adjectives)
(parse-word nouns))))
练习 4.49
修改parse-word让它忽略「输入的句子」并总是成功产生适当的单词，
就可以用来生成句子。请实现程序生输出十来外句子。
在这里的选择是修改4.1.1节的元循环求值器和实现4.2的惰性求值器。
这次要基于4.1.7节的分析求值器实现amb求值器。因为它可以方便地回溯。
(define (list-amb li)
(if (null? li)
(amb)
(amb (car li) (list-amb (cdr li)))))
(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-amb (cdr word-list)))) ;; change
gets:
the student for the student studies for the student
the student for the student studie for the professor
the student for the student studie for the cat
the student for the student studie for the class
the student for the student studie for a student
the student for the student studie for a professor
the student for the student studie for a cat
the student for the student studie for a class
the student for the student studie to the student
the student for the student studie to the professor
实现amb求值器
非确定性的解释器实现起来更加复杂，因为要处理在分支选择时遇到死胡同， 必须回溯到上一个选择点的情况。
amb求值器是在4.1.7节的分析求值器的基础上修改的，而不是4.1.1节或4.2节的求值器， 那是因为它的框架更加更加便于实现回溯。
对表达式的求值过程同样也是通过调用对表达式分析后生产的执行过程。 二者的主要差异都在在有关执行过程的部分。
执行过程和继续
- 普通求值器需要一个参数：执行环境。
-
amb求值器需要三个参数：
- 执行环境
- 名为「成功继续」的过程：分枝执行成功时调用。
- 名为「失败继续」的过程：分枝执行失败时调用。
成功继续过程需要两个参数，一个是继续运行下去的参数值。 还有一个是另一个失败继续过程，因为这个成功继续过程在执行的结果也有可能会失败。
对于amb实现的代码，与4.1.7节的差异主要差异在于执行过程中需要额外的参数把 成功执行过程和失败执行过程传来传去。看本节的代码时通过对比加深理解。
如果一个操作会有副作用（如赋值），那么当遇到到死胡同时， 在做新选择前要撤销副作用。实现的方案是让产生副作用的操作生成一个能撤消副作用， 并传播这一失败的失败继续过程。
总结一下，失败继续过程的构造来自：
- amb表达式走到死胡同时，可以做另一种选择。
- 最高层驱动循环在用光所有选择时报告失败结果。
- 赋值在回溯之前会被撤消。
失败的原因是遇到死胡同，这种情况出现在：
- 用户程序执行amb时。
-
用户输入
try-again给最高层驱动程序时。
失败继续过程会在处理失败过程中被调用：
- 赋值构造出的失败继续过程完成了撤消息的副作用后，会调用所有拦截失败的继续过程， 目的是把失败传播给导致这次赋值的选择点，或传到最高层。
- 当某个amb的失败继续过程用完了所有的选择，会调用原来给这个amb的失败继续过程， 目的是把失败传播给上一个选择点，或传到最高层。
求值器的结构
为了实现amb的特殊形式，需要在4.1.7节的基础上增加语法过程（假设求值器支持let， 见练习4.22）：
(define (amb? exp) (tagged-list? exp 'amb)) (define (amb-choices exp) (cdr exp))
analyze里要增加一个分派子句，识别这一特殊形式并生成适当的执行过程：
((amb? exp) (analyze-amb exp))
最高层的ambeval过程和4.1.7节里的eval类似，会分析表达式，
然后把执行过程应用到环境和两个继续过程上：
(define (ambeval exp env succeed fail) ((analyze exp) env succeed fail))
成功继续过程有两个参数：刚刚得到的值和另一个没有参数的失败继续过程。 如果第一个值的执行导致失败的话，会调用这个失败过程。执行过程的一般形式为：
;; param env is enviroment ;; param succeed is (lambda (value fail) ...) ;; param fail is (lambda () ...) (lambda (env succeed fail) ... )
例如，执行：
(ambeval <exp>
the-global-environment
(lambda (value fail) value)
(lambda () 'failed))
会对表达式exp进行求值，如果成功返回exp的值，失败返回failed。
更加复杂的形式会在驱动循环中看到，那里对ambeval调用了更加复杂的继续过程，
从而实现了对try-again请求的支持。
简单表达式
在4.1.7节的基础上，增加对继续过程的管理。
这些执行过程以有关表达式的值直接成功返回，同时传递给它们的失败继续过程：
(define (analyze-self-evaluating exp)
(lambda (env succeed fail)
(succeed exp fail)))
(define (analyze-quoted exp)
(let ((qval (text-of-quotation exp)))
(lambda (env succeed fail)
(succeed qval fail))))
(define (analyze-variable exp)
(lambda (env succeed fail)
(succeed (lookup-variable-value exp env)
fail)))
(define (analyze-lambda exp)
(let ((vars (lambda-parameters exp))
(bproc (analyze-sequence (lambda-body exp))))
(lambda (env succeed fail)
(succeed (make-procedure vars bproc env)
fail))))
注意，查找变量值总是「成功」。如果lookup-variable-value无法找到这个变量，
它像平常一样返回错误信号。这是一种程序错误，原因是引用了无约束的变量，
而并不是表示应该在这个选择之外再去尝试另一个非确定性选择。
条件和序列
和常规求值器类似：由analyze-if生成执行过程调用谓词执行过程pproc，
pproc的成功继续过程检查谓词是否为真，再调用条件表达式的推论或替代部分。
如果pproc失败，就调用if表达式原来的失败继续过程：
(define (analyze-if exp)
(let ((pproc (analyze (if-predicate exp)))
(cproc (analyze (if-consequent exp)))
(aproc (analyze (if-alternative exp))))
(lambda (env succeed fail)
(pproc env
;; success continuation for evaluating the predicate
;; to obtain pred-value
(lambda (pred-value fail2)
(if (true? pred-value)
(cproc env succeed fail2)
(aproc env succeed fail2)))
;; failure continuation for evaluating the predicate
fail))))
序列要调整sequentially里的部分机制，在这里需要传递继续过程：
如果要顺序地执行a然后执行b，就用一个成功继续过程调用a，
而这个成功继续过程将调用b：
(define (analyze-sequence exps)
(define (sequentially a b)
(lambda (env succeed fail)
(a env
;; success continuation for calling a
(lambda (a-value fail2)
(b env succeed fail2))
;; failure continuation for calling a
fail)))
(define (loop first-proc rest-procs)
(if (null? rest-procs)
first-proc
(loop (sequentially first-proc (car rest-procs))
(cdr rest-procs))))
(let ((procs (map analyze exps)))
(if (null? procs)
(error "Empty sequence -- ANALYZE"))
(loop (car procs) (cdr procs))))
定义和赋值
处理定义时要注意对管理继续过程的管理，必须在实际定义新变量前对定义值表达式求值。
为了完成这一工作，需要「当时的环境」、一个「成功继续过程」和一个「失败继续过程」
，去调用定义值的执行过程vproc。
如果vproc执行成功就得到定义变量所需要的值val，然后定义变量并传播这一成功。
而定义的撤消操作不用考虑，因为可以假定内部定义都已经扫描出来了（见4.1.6节）：
(define (analyze-definition exp)
(let ((var (definition-variable exp))
(vproc (analyze (definition-value exp))))
(lambda (env succeed fail)
(vproc env
(lambda (val fail2)
(define-variable! var val env)
(succeed 'ok fail2))
fail))))
赋值是第一个需要使用继续过程的地方，而不仅仅是把继续过程作为参数传来传去。
赋值的执行过程一开始和定义过程的执行类似，先求出要赋予的值，如果vproc失败，
那么赋值也失败了。
如果vproc成功，那么在赋值前还要为回溯做准备。这需要定义一个成功继续过程
（代码中注释*1*的部分），在赋新值前保存旧的值，然后才赋值。
旧的值要和新值一直传给失败继续过程（代码中注释*2*的部分），用于撤消赋值操作。
这样：一个成功的赋值就提供了一个失败的继续过程，这一过程将接替随后的失败。
如果失败，只要原本需要调用fail2，现在都会转来调用这个过程，在实现调用fail2
前撤消所做的赋值：
(define (analyze-assignment exp)
(let ((var (assignment-variable exp))
(vproc (analyze (assignment-value exp))))
(lambda (env succeed fail)
(vproc env
(lambda (val fail2) ; *1*
(let ((old-value
(lookup-variable-value var env)))
(set-variable-value! var val env)
(succeed 'ok
(lambda () ; *2*
(set-variable-value! var
old-value
env)
(fail2)))))
fail))))
过程应用
过程的应用同样要为了管理各种继续过程处理各种复杂的情况。
复杂的原因是analyze-application需要维护成功和失败过程的轨迹。
在这里get-args过程对运算对象的表进行求值，页不像常规求值器中那样直接用map：
(define (analyze-application exp)
(let ((fproc (analyze (operator exp)))
(aprocs (map analyze (operands exp))))
(lambda (env succeed fail)
(fproc env
(lambda (proc fail2)
(get-args aprocs
env
(lambda (args fail3)
(execute-application
proc args succeed fail3))
fail2))
fail))))
注意：在get-args通过cdr穿过aproc执行过程的表，并用cons构造args的结果表
，其中一个成功继续过程作为参数去调用各个aproc，这种调用里又递归地调用了
get-args。这里对于get-args每个递归调用双都有一个成功继续，
其值是将新得到的实际参数cons到已经积累起来的实际参数表上：
(define (get-args aprocs env succeed fail)
(if (null? aprocs)
(succeed '() fail)
((car aprocs) env
;; success continuation for this aproc
(lambda (arg fail2)
(get-args (cdr aprocs)
env
;; success continuation for recursive
;; call to get-args
(lambda (args fail3)
(succeed (cons arg args)
fail3))
fail2))
fail)))
实际过程应用由execute-application执行，它在常规求值器的基础上，
增加了对继续过程的管理：
(define (execute-application proc args succeed fail)
(cond ((primitive-procedure? proc)
(succeed (apply-primitive-procedure proc args)
fail))
((compound-procedure? proc)
((procedure-body proc)
(extend-environment (procedure-parameters proc)
args
(procedure-environment proc))
succeed
fail))
(else
(error
"Unknown procedure type -- EXECUTE-APPLICATION"
proc))))
对amb表示式进行求值
循环try-next不断地对表达式内所有可能值的执行过程。
每个执行过程的调用都带有一个用来尝试其他可能性的失败继续。
当没有可能性可以试时，整个amb表达式失败。
(define (analyze-amb exp)
(let ((cprocs (map analyze (amb-choices exp))))
(lambda (env succeed fail)
(define (try-next choices)
(if (null? choices)
(fail)
((car choices) env
succeed
(lambda ()
(try-next (cdr choices))))))
(try-next cprocs))))
驱动循环
为了实现在用户输入(try-again)时尝试其他可能性，需要一个internal-loop过程。
它以try-again作为参数，功能是执行下一个分支。
internal-loop或是调用try-again响应用户输入的try-again请求，
或是调用ambeval去开始一个新的求值。
如果ambeval调用失败，会通知用户没有更多的值了，然后会重新调用驱动循环。
如果ambeval调用成功的继续过程，会打印出值，并用一个try-again再次调用内部循环，
尝试下一分支。注意在这里next-alternative过程代替了失败继续过程作为第二个参数，
传递给了传递给了相应的成功继续过程。所以当ambeval求值成功以后，
如果对应的成功继续过程失败，就会调用next-alternative，尝试其他的可能性。
(define input-prompt ";;; Amb-Eval input:")
(define output-prompt ";;; Amb-Eval value:")
(define (driver-loop)
(define (internal-loop try-again)
(prompt-for-input input-prompt)
(let ((input (read)))
(if (eq? input 'try-again)
(try-again)
(begin
(newline)
(display ";;; Starting a new problem ")
(ambeval input
the-global-environment
;; ambeval success
(lambda (val next-alternative)
(announce-output output-prompt)
(user-print val)
(internal-loop next-alternative))
;; ambeval failure
(lambda ()
(announce-output
";;; There are no more values of")
(user-print input)
(driver-loop)))))))
(internal-loop
(lambda ()
(newline)
(display ";;; There is no current problem")
(driver-loop))))
internal-loop初始调用使用了一个try-again过程，当用户在尚未求值时输入
try-again，它打印说目前没有问题，并重新开始驱动循环。
练习 4.50
实现一个特殊形式的ramb，不是按顺序，而是随机尝试各种可能性。
它会对练习4.49中的问题有什么帮助？
meteorgan's answer：
;; In (analyze expr) adds
((ramb? expr) (analyze-ramb expr))
;; add these code to amb evaluator
(define (analyze-ramb expr)
(analyze-amb (cons 'amb (ramb-choices expr))))
;; amb expression
(define (amb? expr) (tagged-list? expr 'amb))
(define (amb-choices expr) (cdr expr))
(define (ramb? expr) (tagged-list? expr 'ramb))
(define (ramb-choices expr) (shuffle-list (cdr expr)))
;; random-in-place, from CLRS 5.3
(define (shuffle-list lst)
(define (random-shuffle result rest)
(if (null? rest)
result
(let* ((pos (random (length rest)))
(item (list-ref rest pos)))
(if (= pos 0)
(random-shuffle (append result (list item)) (cdr rest))
(let ((first-item (car rest)))
(random-shuffle (append result (list item))
(insert! first-item (- pos 1) (cdr (delete! pos rest)))))))))
(random-shuffle '() lst))
;; insert item to lst in position k.
(define (insert! item k lst)
(if (or (= k 0) (null? lst))
(append (list item) lst)
(cons (car lst) (insert! item (- k 1) (cdr lst)))))
(define (delete! k lst)
(cond ((null? lst) '())
((= k 0) (cdr lst))
(else (cons (car lst)
(delete! (- k 1) (cdr lst))))))
Rptx's answer：
; this procedure gets the random element to the start of the list. The rest
; is the same as in amb.
(define (analyze-ramb exp)
(define (list-ref-and-delete ref lst) ; get random item from list.
(define (loop count prev-items rest-items) ; and return a list with the
(if (= count 0) ; random item as its car
(cons (car rest-items) ; and the rest of the list as the cdr
(append prev-items (cdr rest-items)))
(loop (- count 1) ; this will mangle the list every time
(cons (car rest-items) ; creating a "random" amb.
prev-items)
(cdr rest-items))))
(if (null? lst)
'()
(loop ref '() lst)))
(let ((cprocs (map analyze (amb-choices exp))))
(lambda (env succeed fail)
(define (try-next choices)
(if (null? choices)
(fail)
(let ((randomized (list-ref-and-delete
(random (length choices))
choices)))
((car randomized) env
succeed
(lambda ()
(try-next (cdr randomized)))))))
(try-next cprocs))))
练习4.51
定义新的赋值形式permanent-set!，它在失败时不会撤消赋值。
这样一个变量可以用来统计在得到可能的结果前，经过了多少次回溯。
(define count 0)
(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)
如果这里用set!而不是permanent-set!会显示什么？
In analyze adds：
((permanent-set? expr)
(analyze-pernamenant-set expr))
;; add those code.
(define (permanent-set? expr)
(tagged-list? expr 'permanent-set!))
(define (analyze-pernamenant-set expr)
(let ((var (assignment-variable expr))
(vproc (analyze (assignment-value expr))))
(lambda (env succeed fail)
(vproc env
(lambda (val fail2)
(set-variable-value! var val env)
(succeed 'ok fail2))
fail))))
if use set!, the result will be:
(a b 1) (a c 1) ...
练习 4.52
实现if-fail用来捕捉失败，它有两个表达式作为参数。如果第一个执行失败，
会返回第二个表达式的值。例如：
;;; 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
add this in analyze ：
((if-fail? expr) (analyze-if-fail expr))
;; add those to amb evaluator
(define (if-fail? expr) (tagged-list? expr 'if-fail))
(define (analyze-if-fail expr)
(let ((first (analyze (cadr expr)))
(second (analyze (caddr expr))))
(lambda (env succeed fail)
(first env
(lambda (value fail2)
(succeed value fail2))
(lambda ()
(second env succeed fail))))))
练习 4.53
如果采用了练习4.51和练习4.52的permanent-set和if-fail，以下表达式的结果是什么
？
(let ((pairs '()))
(if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
(permanent-set! pairs (cons p pairs))
(amb))
pairs))
((8 35) (3 110) (3 20))
练习 4.54
如果没有认识到require可以用amb实现为一个常规过程，
可以由用户作为非确定性程序的一部分来定义，那么，
可能就不得不将它实现为一个特殊形式。这要用到以下的语法过程：
(define (require? exp) (tagged-list? exp 'require)) (define (require-predicate exp) (cadr exp))
还要在analyze里加上新的派生语句：
((require? exp) (analyze-require exp))
还要用过程analyze-require去处理表达式require。请完成analyze-require的填空
：
(define (analyze-require exp)
(let ((pproc (analyze (require-predicate exp))))
(lambda (env succeed fail)
(pproc env
(lambda (pred-value fail2)
(if <??>
<??>
(succeed 'ok fail2)))
fail))))
(define (analyze-require exp)
(let ((pproc (analyze (require-predicate exp))))
(lambda (env succeed fail)
(pproc env
(lambda (pred-value fail2)
(if (not (true? pred-value))
(fail2)
(succeed 'ok fail2)))
fail))))