The Little Schemer 和 Elisp 学习笔记

最近正好在学习 Elisp, 突然想到之前买了就吃灰的 《The Little Schemer》, 正好来试试使用 Elisp 实现书中的例子。

先列举一下用到的 Elisp 的原生函数

listp

(listp OBJECT)

Return t if OBJECT is a list, that is, a cons cell or nil.
Otherwise, return nil.

car

(car LIST)

Return the car of LIST.  If arg is nil, return nil.
Error if arg is not nil and not a cons cell.

cdr

(cdr LIST)

Return the cdr of LIST.  If arg is nil, return nil.
Error if arg is not nil and not a cons cell.

cons

(cons CAR CDR)

Create a new cons, give it CAR and CDR as components, and return it.

eq

(eq OBJ1 OBJ2)

Return t if the two args are the same Lisp object.

null

(null OBJECT)

Return t if OBJECT is nil, and return nil otherwise.

下面的函数都是自己编写的

我相信大多数下面列出的函数其实都已经有相应的库实现了,不过这里仅作为学习使用

atom?

判断是否为 atom, 实现原理是利用 elisp 自带的 listp 判断对象是不是一个 list, 取反就是了

(defun atom? (x)
  (not (listp x)))

(atom? 123)
(atom? `(a b c))

lat?

用来判断列表是否全部都是由原子组成的

(defun lat? (l)
  (cond
   ((null l) t)
   ((atom? (car l)) (lat? (cdr l)))
   (t nil)))

很简单的递归,先判断 list 的第一个元素是否是 atom, 是的话就 lat? 剩下的元素,如果能执行到第 3 行,即遍历完 list 全部都是 lat? 的话,就返回 t, 最后一行的 t 就是 else 的意思,只要不符合上面的条件(有不是 atom 的),就会执行最后一样,返回 nil (false).

member?

用来判断一个 lat 是否包含某个原子

(defun member? (a lat)
  (cond
   ((null lat) nil)
   ((eq (car lat) a) t)
   (t (member? a (cdr lat)))))

(member? `abc `(abc xyz))

cond 中第一行,先判断 lat 是否是空,因为这个是边际条件,是递归的终点,要最先判断,然后和 lat? 一样只要递归判断每个元素即可。

rember

移除 lat 中首个 a 原子,返回一个新列表

(defun rember (a lat)
  (cond
   ((null lat) nil)
   ((eq (car lat) a) (cdr lat) )
   (t (cons (car lat) (rember a (cdr lat))))))

(rember `mint `(lamb chops and mint jelly))

这里先不断的比较 car lat 的值和参数 a 是否一致,一致的话就返回 cdr lat, 否则就递归调用 rember,还是以 lat 是 null 为终点。

firsts

获取参数中每个列表的第一个元素

(defun firsts(l)
  (cond
   ((null l) `())
   (t (cons (car (car l)) (firsts (cdr l) )))))

(firsts `())
(firsts `((a b) (c d) (e f)))

递归 l 中的每个 list, 然后获取 list 的第一个元素,全部 cons 起来

insertR

lat 中的第一个 old 右边插入 new

  (defun insertR(new old lat)
    (cond
     ((null lat) `())
     ((eq (car lat) old)(cons old (cons new (cdr lat))))
     (t (cons (car lat) (insertR new old (cdr lat))))))

(insertR `topping `fudge `(ice cream with fudge for dessert))

有点复杂,还是先递归,然后直到发现 old, 这时把 new 插入,后面继续递归

insertL

参考 insertR

(defun insertL(new old lat)
  (cond
   ((null lat) `())
   ((eq (car lat) old)(cons new lat))
   (t (cons (car lat) (insertL new old (cdr lat))))))

(insertL `topping `fudge `(ice cream with fudge for dessert))

subst

用 new 替代 lat 中的首个 old

(defun subst(new old lat)
  (cond
   ((null lat) `())
   ((eq (car lat) old) (cons new (cdr lat)))
   (t (cons (car lat) (subst new old (cdr lat))))))

(subst `topping `fudge `(ice cream with fudge for dessert))

和上面两个思路一样,而且更简单,把插入的逻辑改为替换即可

subst2

用 new 替代 lat 中的首个 o1 o2

(defun subst2(new o1 o2 lat)
  (cond
   ((null lat) `())
   ((or (eq (car lat) o1) (eq (car lat) o2)) (cons new (cdr lat)))
   (t (cons (car lat) (subst2 new o1 o2 (cdr lat))))))

(subst2 `vanilla `chocolate `banana `(ban2ana ice cream with chocolate topping))

multirember

移除 lat 中所有的 a

(defun multirember(a lat)
  (cond
   ((null lat) `())
   ((eq (car lat) a) (multirember a (cdr lat)))
   (t (cons (car lat) (multirember a (cdr lat))))))

(multirember `cup `(coffee cup tea cup and hick cup))

多个的情况,唯一的不同就是 eq 那行的递归调用了,之前的 “一次性” 的版本的代码,都是进去 eq 条件后就不会递归调用了,只要继续递归调用,就能处理多个的情况了。

multiinsertR

insertR 的 multi 版本

  (defun multiinsertR(new old lat)
    (cond
     ((null lat) `())
     ((eq (car lat) old)(cons old (cons new (multiinsertR new old (cdr lat)))))
     (t (cons (car lat) (multiinsertR new old (cdr lat))))))

(multiinsertR `topping `fudge `(ice cream with fudge ice cream with fudge))

同理和 insertR 相比,就是在出现 eq 情况后继续递归调用

multiinsertL

insertL 的 multi 版本

  (defun multiinsertL(new old lat)
    (cond
     ((null lat) `())
     ((eq (car lat) old)(cons new (cons old (multiinsertL new old (cdr lat)))))
     (t (cons (car lat) (multiinsertL new old (cdr lat))))))

(multiinsertL `topping `fudge `(ice cream with fudge ice cream with fudge))

这里只要注意 eq 的情况下先 cons new 再 cons old 再递归这个顺序就行

multisubst

subst 的 multi 版本

(defun multisubst(new old lat)
  (cond
   ((null lat) `())
   ((eq (car lat) old) (cons new (multisubst new old (cdr lat))))
   (t (cons (car lat) (multisubst new old (cdr lat))))))

(multisubst `topping `fudge `(ice cream with fudge ice cream with fudge))

o+

其实就是 + 的意思,只不过 + 是已有的函数,这里相当于我们自己实现一个 +

(defun o+ (n m)
  (cond
   ((zerop m) n)
   (t (+ 1 (o+ n (- m 1))))))

(o+ 2 3)

这里的 zerop 就是之前的 eq, 是结束递归的条件

o-

(defun o- (n m)
  (cond
   ((zerop m) n )
   (t (- (o- n (- m 1)) 1))))

(o-  4 3)

addup

把 tup 中的数字求和

(defun addup(tup)
  (cond
   ((null tup) 0)
   (t (+ (car tup) (addup (cdr tup) )))))

(addup `(1 2 3 4))

就是把之前用的 cons 改成了 +, 结束条件的 `() 改成了 0.

o*

乘法

(defun o* (m n)
  (cond
   ((zerop n) 0)
   (t (o+ m (o* m (o- n 1))))))

(o* 3 5)

这个可能会脑子转不过来,3 x 5 的意思就是 5 个 3 相加 ( 3 + 3 + 3 + 3 + 3), 所以可以写作 3 + (3 + 3 + 3 + 3), 即 (3 + 3 x 4), 明白了把,就是这样递归来的。

tup+

对长度相同的两个 tup 参数,对同样位置的数字进行球和,然后产生一个新的 tup

(defun tup+ (tup1 tup2)
  (cond
   ((and (null tup1) (null tup2)) `())
   (t (cons (+ (car tup1) (car tup2)  ) (tup+ (cdr tup1) (cdr tup2))))))

(tup+ `(1 2) `(3 4))

o>

比大小

  (defun o> (m n)
  (cond
   ((zerop m) nil)
   ((zerop n) t)
   (t (o> (- m 1) (- n 1)))))

(o> 4 5)
(o> 4 4)
(o> 5 4)

只需要注意先判断 m == 0 的情况,不然碰到 m == n 的时候就不对了

o<

  (defun o< (m n)
  (cond
   ((zerop n) nil)
   ((zerop m) t)
   (t (o< (- m 1) (- n 1)))))

(o< 4 5)
(o< 4 4)
(o< 5 4)

o=

(defun o= (m n)
  (cond
   ((> m n) nil)
   ((< m n) nil)
   (t)))

(o= 4 5)
(o= 4 4)
(o= 5 4)

太简单了,两个数,谁也不比谁大,谁也不比谁小,那就是相等了(正整数)

o^

次方

(defun o^ (m n)
  (cond
   ((zerop n) 1)
   (t (o* m (o^ m (- n 1))))))

(o^ 2 3)

2 的 3 次方,就是 2 x 2 x 2, 就是 2 x 两个 2 相乘, 就是 2 x 2 x 一个二相乘,懂了吧

o/

除法

(defun o/ (m n)
  (cond
   ((o< m n) 0 )
   (t(o+ 1 (o/ (o- m n) n )))))

(o/ 15 4)

除法,就是 m 能包含多少个 n, 15 除 4, 就是 15 包含了 3 个 4, 减去一个 4 是 11, 再减去是 7, 再减 3, 没了,一共减了 3 次,所以答案是 3.

length

计算一个 lat 的长度

  (defun length(lat)
    (cond
     ((null lat) 0)
     (t (o+ 1 (length (cdr lat))))))

(length `(a b c))

pick

从 lat 中选取第 n 个元素

(defun pick(n lat)
  (cond
   ((zerop (o- n 1)) (car lat))
   (t (pick (- n 1) (cdr lat)))))

(pick 4 `(a b c d e))

这个函数中,n 和 lat 都需要不断变化,n 每次减 1, lat 每次去掉第一个元素,当 n = 0 是,lat 的第一个元素就是我们要的值了。

repick

从 lat 中去掉第 n 个元素,并返回剩下的

  (defun repick(n lat)
    (cond
     ((zerop (o- n 1)) (cdr lat))
     (t (cons (car lat) (repick (- n 1) (cdr lat))))))

(repick 2 `(a b c d))

no-nums

移除 lat 中所有的数字,需要内建函数 numberp

(defun no-nums(lat)
  (cond
   ((null lat) `())
   ((numberp (car lat)) (no-nums (cdr lat)))
   (t (cons (car lat) (no-nums(cdr lat))))))

(no-nums `(a 1 b 2 c 3))

all-nums

取出 lat 中所有的数字,需要内建函数 numberp

(defun all-nums(lat)
  (cond
   ((null lat) `())
   ((numberp (car lat)) (cons (car lat) (all-nums (cdr lat))))
   (t (all-nums(cdr lat)))))

(all-nums `(a 1 b 2 c 3))

可以和上面的 no-nums 对比学习

eqan?

对象两个参数原子,注意数字和其他类型的比较方式不同

(defun eqan?(a b)
  (cond
   ((and (numberp a) (numberp b)) (o= a b))
   ((or (numberp a) (numberp b)) nil)
   (t (eq a b))))

(eqan? 1 1)
(eqan? 1 2)
(eqan? 1 `a)
(eqan? `a `a)
(eqan? `a `b)

occur

统计原子 a 在列表 lat 中出现的次数

(defun occur(a lat)
  (cond
   ((null lat) 0)
   ((eqan? a (car lat)) (o+ 1 (occur a (cdr lat))))
   (t (occur a (cdr lat)))))

(occur 1 `(1 2 1 2 1))

one?

如果参数 n 是 1, 就返回 true, 否则 false

(defun one?(n)
  (cond
   ((eqan? 1 n) t)
   (t nil)))

(one? 1)
(one? 2)
(one? `a)

rember*

rember 的支持嵌套版本

  (defun rember*(a l)
    (cond
     ((null l) `())
     ((atom? (car l))
      (cond
       ((eq (car l) a) (rember* a (cdr l)))
       (t (cons (car l) (rember* a (cdr l))))))
     (t (cons(rember* a (car l)) (rember* a (cdr l))))))

(rember* `cup `((coffee) cup ((tea) cup)(and (hick)) cup))
(rember* `sauce `(((tomato sauce)) ((bean) sauce)(and ((flying)) sauce)))

为了添加嵌套的支持,逻辑多了不少,不过主要思路是不变的。 首先判断是否是 null, 然后每次对第一个元素进行判断,不是 atom 的话进入最后的 t (else) 的逻辑,就是用把 l 的第一个元素和剩下的列表分别进行递归,然后 cons 起来。 对于是 atom 的情况,就分为和 a 是否 eq, eq 的话就递归剩下的列表,否则就把第一个元素和剩下的列表递归后 cons. 可以对比一下 multirember 的实现, 可以发现第二个 cond 下面的两行, 和 multirember 的最后两行形式上一模一样,可见,当前首元素是 atom 的时候, 处理逻辑和 lat 一致,当首元素不是 atom 的时候,直接递归,让 l 去掉首元素,最后全部连起来。

insertR*

insertR 的支持嵌套版本

(defun insertR*(new old l)
  (cond
   ((null l) `())
   ((atom? (car l))
    (cond
     ((eq (car l) old) (cons old (cons new (insertR* new old (cdr l)))))
     (t (cons (car l) (insertR* new old (cdr l))))))
   (t (cons (insertR* new old (car l)) (insertR* new old (cdr l))))))

(insertR* `roast `chuck `((how much (wood)) could ((a (wood) chuck)) (((chuck))) (if(a)((wood chuck))) could chuck wood))

判断的步骤和上面的一样,先判断是否是 null, 然后拿第一个元素开刀,判断是否是 atom, 是的话进入和 insertR 一样的步骤。 不是的话直接递归调用,用 cons 连接。

occur*

计算 a 在 l 中出现的次数

  (defun occur*(a l)
    (cond
     ((null l) 0)
     ((atom? (car l))
      (cond
       ((eq a (car l)) (o+ 1 (occur* a (cdr l))))
       (t (occur* a (cdr l)))))
     (t (o+ (occur* a (car l)) (occur* a (cdr l))))))

(occur* `banana `((banana) (split ((((banana ice))) (cream (banana)) sherbet)) (banana) (bread) (banana brandy)))

一样的套路,无非就是把 cons 换成了 o+, 还是先问 null, 在问 atom, 其他都一样

subst*

把 l 中所有的 old 替换为 new

(defun subst* (new old l)
  (cond
   ((null l) `())
   ((atom? (car l))
    (cond
     ((eq old (car l)) (cons new (subst* new old (cdr l))))
     (t (cons (car l) (subst* new old (cdr l)) ))))
   (t (cons (subst* new old (car l))( subst* new old (cdr l))))))

(subst* `orange `banana `((banana) (split((((banana ice))) (cream (banana)) sherbet)) (banana) (bread) (banana brandy)))

参考之前的 insertR*, 类似的实现还更简单一点。

insertL*

insertR* 的镜像版本

(defun insertL*(new old l)
  (cond
   ((null l) `())
   ((atom? (car l))
    (cond
     ((eq old (car l)) (cons new (cons old (insertL* new old (cdr l)))))
     (t (cons (car l) (insertL* new old (cdr l))))))
   (t (cons (insertL* new old (car l)) (insertL* new old (cdr l))))))

(insertL* `pecker `chuck `((how much (wood)) could ((a (wood) chuck)) (((chuck))) (if(a)((wood chuck))) could chuck wood))

member*

member 的支持嵌套版本

(defun member*(a l)
  (cond
   ((null l) nil)
   ((atom? (car l))
    (cond
     ((eq a (car l)) t)
     (t (member* a (cdr l)))))
   (t (or (member* a (car l)) (member* a (cdr l))))))

(member* `chips `((potato)(chips ((with) fish) (chips))))
(member* `chips `(abc))

唯一需要注意的是,最后一行,递归 (car l) 和 (cdr l) 的关系应该是用 or

leftmost

找出 s 表达式列表中最左边的原子(列表不包含空列表)

(defun leftmost(l)
  (cond
   ((atom? (car l)) (car l))
   (t (leftmost (car l) ))))

(leftmost `((potato)(chips ((with) fish) (chips))))

eqlist?

判断两个列表是否相等

(defun eqlist? (l1 l2)
  (cond
   ((and (null l1) (null l2)) t)

   ((and (null l1) (atom? (car l2))) nil)

   ((null l1) nil)

   ((and (atom? (car l1)) (null l2)) nil)

   ((and (atom? (car l1)) (atom? (car l2)))
    (and (eqan? (car l1) (car l2))
         (eqlist? (cdr l1) (cdr l2))))

   ((atom? (car l1)) nil)

   ((null l2) nil)

   ((atom? (car l2)) nil)

   (t (and (eqlist? (car l1) (car l2)) (eqlist? (cdr l1) (cdr l2))))))

(eqlist? `(beef ((sausage)) (and (soda))) `(beef ((sausage)) (and (soda))))
(eqlist? `(abc) `(xyz))

函数特别长,一行一行来看。

  1. l1 和 l2 都是空,那就是 true 了,最简单的判断
  2. l1 是空, l2 的第一个元素是 atom, 那肯定不相等
  3. l1 是空,由于 l2 也是空的情况一开始就排除了,所以也是 false
  4. l1 第一个元素是 atom, l2 是空, false
  5. l1 和 l2 的第一个元素都是 atom, 则对比它们,如果相当,进入递归 cdr 剩下的部分
  6. l1 的第一个元素是 atom, false
  7. l2 是空, false
  8. l2 的第一个元素是空,false
  9. 其实就是 l1 和 l2 的第一个元素都是列表,进入递归

上面的算法有可以省略的部分,优化后如下:

(defun eqlist? (l1 l2)
  (cond
   ((and (null l1) (null l2)) t)

   ((or (null l1) (null l2)) nil)

   ((and (atom? (car l1)) (atom? (car l2)))
    (and (eqan? (car l1) (car l2))
         (eqlist? (cdr l1) (cdr l2))))

   ((or (atom? (car l1)) (atom? (car l2))) nil)

   (t (and (eqlist? (car l1) (car l2)) (eqlist? (cdr l1) (cdr l2))))))

(eqlist? `(beef ((sausage)) (and (soda))) `(beef ((sausage)) (and (soda))))
(eqlist? `(abc) `(xyz))

再来一行一行看看:

  1. l1 和 l2 都是 null, 返回 true
  2. l1 和 l2 有一个是 null, 另一个不是,返回 false
  3. 递归的情况,和之前的实现一样
  4. l1 和 l2 的第一个元素,有一个是 atom, 另一个不是,返回 false
  5. 递归的情况,和之前的实现一样

需要注意的是,cond 里的大量表达式是有顺序的,比如第一步先过滤掉了 l1 和 l2 都是 null 的情况, 所以第二步才能理解为一个是 null, 另一个不是,因为两个都是 null 的情况已经不会进入这里了。

equal?

判断两个 s 表达式是否相同

(defun equal? (s1 s2)
  (cond
   ((and (atom? s1) (atom? s2)) (eqan? s1 s2))
   ((or (atom? s1) (atom? s2)) nil)
   (t (eqlist? s1 s2))))

(equal? `(beef ((sausage)) (and (soda))) `(beef ((sausage)) (and (soda))))
(equal? `(abc) `(xyz))

等等, equal? 和 eqlist? 有什么区别?

equal? 处理了 eqlist? 问题中的一个子集,即 s 表达式的判断

那么我们可以用 equal? 来实现 eqlist? 了,只要在 eqlist? 中做一些空的判断,然后剩下的就通过 equal? 函数就行了

(defun eqlist?(l1 l2)
  (cond
   ((and (null l1) (null l2)) t)
   ((or (null l1) (null l2)) nil)
   (t (and (equal? (car l1) (car l2)) (eqlist? (cdr l1) (cdr l2))))))

(eqlist? `(beef ((sausage)) (and (soda))) `(beef ((sausage)) (and (soda))))
(eqlist? `(abc) `(xyz))

这样一来 eqlist? 和 equal? 互相调用了,这是怎么回事?其实只要把 equal? 当成一个中间人就行了,没有 equal? 我们一样在第一版中就实现了 eqlist? 所以 equal? 无非就是抽取了一段逻辑而已。

numbered?

判断一个表达式是不是数字

(defun numbered? (aexp)
  (cond
   ((atom? aexp) (numberp aexp))

   ((eq (car (cdr aexp)) (quote +))
    (and (numbered? (car aexp))
         (numbered? (car (cdr (cdr aexp))))))

   ((eq (car (cdr aexp)) (quote *))
    (and (numbered? (car aexp))
         (numbered? (car (cdr (cdr aexp))))))

   ((eq (car (cdr aexp)) (quote ^))
    (and (numbered? (car aexp))
         (numbered? (car (cdr (cdr aexp))))))))

(numbered? `(1 + 3))
(numbered? `(2 ^ 3))
(numbered? `(3 * 4))
(numbered? `(abc))

代码不少,但逻辑不复杂,先判断是不是 atom, 是的话好办,直接判断这个 atom 是不是 nubmer 就行了 (numberp 函数).

之后的 (car (cdr aexp)) 就是第二个元素的意思,判断是否是 + * ^ 这样的操作符,是的话就递归调用之前和之后的表达式,最后用 and 连起来。

代码中的重复很明显,可以优化:

(defun numbered? (aexp)
  (cond
   ((atom? aexp) (numberp aexp))
   (t (and (numbered? (car aexp)) (numbered? (car (cdr (cdr aexp))))))))


(numbered? `(1 + 3))
(numbered? `(2 ^ 3))
(numbered? `(3 * 4))
(numbered? `(abc))

这里我们直接消除了对于 ‘中间‘ 的操作符的判断,只判断前后两个子表达式是否是可计算的。

value

返回可计算算术表达式的一般性值

  (defun value (nexp)
    (cond
     ((atom? nexp) nexp)

     ((eq (car nexp) (quote +))
      (o+ (value (car (cdr nexp)))
          (value (car (cdr (cdr nexp))))))

     ((eq (car nexp) (quote *))
      (o* (value (car (cdr nexp)))
          (value (car (cdr (cdr nexp))))))

     (t (o^ (value (car (cdr nexp)))
            (value (car (cdr (cdr nexp))))))))

(value `(+ 1 2))

但是这样写很不灵活,不能很好的应对不同表达式格式的支持,比如 (+ 1 3) 和 (1 + 3).

所以我们可以抽取几个函数

(defun 1st-sub-exp (aexp)
  (car (cdr aexp)))

(defun 2nd-sub-exp (aexp)
  (car (cdr (cdr aexp))))

(defun operator (aexp)
  (car aexp))

(defun value (nexp)
  (cond
   ((atom? nexp) nexp)
   ((eq (operator nexp) (quote +))
    (o+ (value (1st-sub-exp nexp))
        (value (2nd-sub-exp nexp))))
   ((eq (operator nexp) (quote *))
    (o* (value (1st-sub-exp nexp))
        (value (2nd-sub-exp nexp))))
   (t (o^ (value (1st-sub-exp nexp))
          (value (2nd-sub-exp nexp))))))

这样一来,哪个是操作符,哪个是子表达式的逻辑就被分开了,修改起来就变得容易了。

set?

判断 lat 中有没有重复的原子

  (defun set?(lat)
    (cond
     ((null lat) t)
     ((member? (car lat) (cdr lat)) nil)
     (t (set? (cdr lat)))))

(set? `())
(set? `(a))
(set? `(a a))

利用 member? 函数,递归调用 car lat 和 cdr lat

makeset

对 lat 去重

(defun makeset(lat)
  (cond
   ((null lat) `())
   ((member? (car lat) (cdr lat)) (makeset (cdr lat)))
   (t (cons (car lat) (makeset (cdr lat))))))

(makeset `(apple peach pear peach plum apple lemon peach))

上面的写法是使用 member? 函数来判断是否有同样的值,其实还可以使用 multirember 来直接去掉后面出现的同样的值

(defun makeset(lat)
  (cond
   ((null lat) `())
   (t (cons (car lat) (makeset (multirember (car lat) (cdr lat)))))))

(makeset `(apple peach pear peach plum apple lemon peach))

subset?

set1 中的元素是否全部包含在 set2 中

  (defun subset? (set1 set2)
    (cond
     ((null set1) t)
     ((member? (car set1) set2) (subset? (cdr set1) set2))
     (t nil)))

(subset? `(5 chicken wings) `(5 hamburgers 2 pieces fried chicken and light duckling wings))
(subset? `(4 pounds of horseradish) `(four pounds chicken and 5 ounces horseradish))

使用 and 来重构

(defun subset? (set1 set2)
  (cond
   ((null set1) t)
   (t (and (member? (car set1) set2) (subset? (cdr set1) set2)))))

(subset? `(5 chicken wings) `(5 hamburgers 2 pieces fried chicken and light duckling wings))
(subset? `(4 pounds of horseradish) `(four pounds chicken and 5 ounces horseradish))

eqset?

判断两个 set 相等(set 不要求顺序)

  (defun eqset? (set1 set2)
    (and (subset? set1 set2) (subset? set2 set1 )))

(eqset? `(6 large chickens with wings) `(6 chickens with large wings))
(eqset? `(abc xyz) `(abc))

intersect?

set1 中至少有一个原子也存在于 set2 中

(defun intersect? (set1 set2)
  (cond
   ((null set1) nil)
   ((member? (car set1) set2) t )
   (t (intersect? (cdr set1) set2))))

(intersect? `(stewed tomatoes and macaroni) `(macaroni and cheese))
(intersect? `(abc def) `(uvw xyz))

可以用 or 重构

(defun intersect? (set1 set2)
  (cond
   ((null set1) nil)
   (t (or (member? (car set1) set2)  (intersect? (cdr set1) set2)))))

(intersect? `(stewed tomatoes and macaroni) `(macaroni and cheese))
(intersect? `(abc def) `(uvw xyz))

intersect

取 set1 和 set2 共有的原子

(defun intersect (set1 set2)
  (cond
   ((null set1) `())
   ((member? (car set1) set2) (cons (car set1) (intersect (cdr set1) set2)))
   (t (intersect (cdr set1) set2))))

(intersect `(stewed tomatoes and macaroni) `(macaroni and cheese))

union

把两个 set 合起来

  (defun union (set1 set2)
    (cond
     ((null set1) set2)
     ((member? (car set1) set2) (union (cdr set1) set2))
     (t (cons (car set1) (union (cdr set1) set2)))))

(union `(stewed tomatoes and macaroni casserole) `(macaroni and cheese))

intersectall

对 l-set 中的所有 set 取其共有的元素 (l-set 非空)

(defun intersectall (l-set)
  (cond
   ((null (cdr l-set)) (car l-set))
   (t (intersect (car l-set) (intersectall (cdr l-set) )))))

(intersectall `((6 pears and)
                (3 peaches and 6 peppers)
                (8 pears and 6 plumn)
                (and 6 prunes with some apples)))

a-pair?

判断是否是 pair

(defun a-pair? (x)
  (cond
   ((atom? x) nil)
   ((null x) nil)
   ((null (cdr x)) nil)
   ((null (cdr (cdr x))) t)))

(a-pair? `())
(a-pair? `(a))
(a-pair? `(a b))
(a-pair? `((a) (b)))
(a-pair? `((a) (b c) (d)))

first secod build

工具函数,用来获取 pair 中的两个元素,并把它们组成一个 pair

(defun first(p)
  (car p))
(defun second(p)
  (car (cdr p)))
(defun build(s1 s2)
  (cons s1 (cons s2 `())))

fun?

判断 l 是否是由 pair 组成的 set

  (defun fun?(rel)
    (set? (firsts rel)))

(fun? `((apples peaches) (pumpkin pie) (apples peaches)))
(fun? `((apples peaches) (pumpkin pie)))

revrel

反转 rel 中每个 pair

(defun revrel (rel)
  (cond
   ((null rel) `())
   (t (cons (build (second (car rel)) (first (car rel))) (revrel (cdr rel)) ))))

(revrel `((8 a) (pumpkin pie) (got sick)))

可以抽取 revpair 函数

  (defun revpair(pair)
    (build (second pair) (first pair)))

(revpair `(a 1))

这样 revrel 函数可以简化为:

(defun revrel (rel)
  (cond
   ((null rel) `())
   (t (cons (revpair(car rel)) (revrel (cdr rel)) ))))

(revrel `((8 a) (pumpkin pie) (got sick)))

fullfun?

列表中的 pair 的第二个元素可以组成一个 set

这里先定义一下 seconds 这个帮助函数:

(defun seconds(l)
  (cond
   ((null l) `())
   (t (cons (car (cdr (car l))) (seconds (cdr l) )))))

(seconds `())
(seconds `((a b) (c d) (e f)))
(defun fullfun? (fun)
  (set? (seconds fun)))

(fullfun? `((grape raisin) (plum prune) (stewed grape)))
(fullfun? `((grape raisin) (plum prune) (stewed prune)))

rember-f

移除 l 中的 a, 但是符合条件的逻辑在 test? 中

(defun rember-f (test? a l)
  (cond
   ((null l) `())
   ((funcall test? (car l) a) (cdr l))
   (t (cons (car l) (rember-f test? a (cdr l))))))

(rember-f (function eq) 5 `(6 2 5 3))

eq?-c

返回一个函数,测试参数 x 是否等于 c, 这里以 `salad 为例:

(setq lexical-binding t)

(defun eq?-c (a)
  (lambda (x)
    (eq x a)))

(eq?-c 'salad) ;; 返回的是函数
(setq eq?-salad (eq?-c 'salad)) ;; 把函数赋值给 eq?-salad 变量
(funcall eq?-salad 'salad)

rember-f

重写这个函数,使用 currying 的方式:

(defun rember-f (test?)
  (lambda (a l)
    (cond
     ((null l) `())
     ((funcall test? (car l) a) (cdr l))
     (t (cons (car l) (rember-f test? a (cdr l)))))))

(setq rember-eq? (rember-f (function eq)))
(funcall rember-eq? `tuna `(tuna salad is good))

insertL-f

insertL 的 currying 版本

(defun insertL-f (test?)
  (lambda (new old lat)
    (cond
     ((null lat) `())
     ((funcall test? (car lat) old)(cons new lat))
     (t (cons (car lat) (funcall(insertL-f test?) new old (cdr lat)))))))

(funcall (insertL-f (function eq)) `topping `fudge `(ice cream with fudge for dessert))

方法体中的代码和原版 insertL 几乎一样,就是把 eq 的地方改成了 test?

insertR-f

insertR 的 currying 版本

(defun insertR-f(test?)
  (lambda (new old lat)
    (cond
     ((null lat) `())
     ((funcall test? (car lat) old)(cons old (cons new (cdr lat))))
     (t (cons (car lat) (funcall(insertR-f test?) new old (cdr lat)))))))

(funcall (insertR-f (function eq)) `topping `fudge `(ice cream with fudge for dessert))

seqL

三个参数 new old l, 把 old cons 到 l 上, 再把 new cons 到前者

(defun seqL(new old l)
  (cons new (cons old l)))

seqR

和 seqL 类似,只不过把 new 和 old 对调

(defun seqR(new old l)
  (cons old (cons new l)))

insert-g

根据传入的 seq 来决定 insert 的顺序

(defun insert-g(seq)
  (lambda (new old l)
    (cond
     ((null l) `())
     ((eq (car l) old) (funcall seq new old (cdr l)))
     (t (cons (car l) (funcall (insert-g seq) new old (cdr l)))))))

重新实现 insertL

(setq insertL (insert-g (function seqL)))
(funcall insertL `topping `fudge `(ice cream with fudge for dessert))

同理, insertR

(setq insertR (insert-g (function seqR)))
(funcall insertR `topping `fudge `(ice cream with fudge for dessert))

seqS

直接 cons new 和 l, 把 old 丢弃

(defun seqS (new old l)
  (cons new l))

重新定义 subst

(setq subst (insert-g (function seqS)))
(funcall subst `topping `fudge `(ice cream with fudge for dessert))

seqrem

(defun seqrem (new old l)
  l)

new 和 old 都没了?只剩下 l, 这不就是 rember 吗

(defun rember (a l)
  (funcall(insert-g (function seqrem)) nil a l ))

(rember `mint `(lamb chops and mint jelly))

atom-to-function

把原子操作符传为函数

(defun atom-to-function(x)
  (cond
   ((eq x (quote +)) (function o+))
   ((eq x (quote *)) (function o*))
   (t (function o^))))

(atom-to-function (quote +))

重写一下 value 函数

  (defun value(nexp)
    (cond
     ((atom? nexp) nexp)
     (t (funcall(atom-to-function (operator nexp))
                (value (1st-sub-exp nexp))
                (value (2nd-sub-exp nexp))))))

(value (+ 1 2))

这次的重构,之前的逻辑已经不重要了,重点是之前的旧实现,先获取操作符,再进行操作,现在的做法是,直接返回一个操作函数,用 funcall 调用,参数是 1st-sub-exp 的 value 和 2nd-sub-exp 的 value

multirember-f

multirember 的 currying 版本

(defun multirember-f(test?)
  (lambda (a lat)
    (cond
     ((null lat) `())
     ((funcall test? (car lat) a)
      (funcall (multirember-f test?) a (cdr lat)))
     (t (cons (car lat)
              (funcall (multirember-f test?) a (cdr lat) ))))))

(funcall (multirember-f (function eq)) `tuna `(shrimp salad tuna salad and tuna))

multiremberT

和 multirember-f 类似,但是返回的不是函数,而是直接传一个 test? 函数和一个 lat.

先定义这个 test? 参数

(setq eq?-tuna (eq?-c `tuna))

然后传如这个 eq?-tuna 函数

(defun multiremberT(test? lat)
  (cond
   ((null lat) `())
   ((funcall test? (car lat))
    (multiremberT test? (cdr lat)))
   (t (cons (car lat) (multiremberT test? (cdr lat))))))

(multiremberT eq?-tuna `(shrimp salad tuna salad and tuna))

这里需要对比一下之前的 multirember-f

首先,之前的 -f 版本的函数,都是先接收一个 test? 函数,然后返回一个函数,再对这个函数传入参数。

这个 T 版本,是把函数和参数一起传入,相当于 test? 和 a 合在一起了

multirember&co

这个函数很复杂, co 是 collector 的意思,直接看例子

(defun multirember&co (a lat col)
  (cond
   ((null lat)
    (funcall col (quote ()) (quote ())))
   ((eq (car lat) a)
    (multirember&co a (cdr lat)
                    (lambda (newlat seen)
                      (funcall col newlat
                               (cons (car lat) seen)))))
   (t (multirember&co a (cdr lat)
                      (lambda (newlat seen)
                        (funcall col (cons (car lat) newlat)
                                 seen))))))

这个 col 就是 collector, 我们举个例子

(defun a-friend (x y)
  (null y))

(a-friend 5 nil)

这里有个 a-friend 函数,就是判断第二个参数 y 是否是 nil

我们来把这个 a-friend 作为 col 传入 multirember&co

(multirember&co 'tuna '() (function a-friend))

(multirember&co 'tuna '(tuna) (function a-friend))

(multirember&co 'tuna '(and tuna) (function a-friend))

(multirember&co 'tuna '(strawberries tuna and swordfish)
                (function a-friend))

再来看看函数的定义,multirember&co 会把 lat 中符合 a 的条件 (这里是 eq) 作为列表2,

不符合的作为列表1, 再把列表1 和 列表2作为 col (这里是 a-friend) 的参数。

所以在使用 a-friend 的情况下, multirember&co 的功能是判断 lat 中是否包含 a (取反)

当然根据 col 函数的不同,可以实现的功能就相当多了,比如:

(defun last-friend (x y)
  (length x))

(multirember&co 'tuna '(stawberries tuna and swordfish) (function last-friend))

这个函数就是计算出 lat 中不是 a 的原子的数量。

multiinsertLR

这个函数是 multiinsertL 和 multiinsertLR 的组合版本

(defun multiinsertLR (new oldL oldR lat)
  (cond
   ((null lat) (quote ()))
   ((eq (car lat) oldL) (cons new (cons oldL (multiinsertLR new oldL oldR (cdr lat)))))
   ((eq (car lat) oldR) (cons oldR (cons new (multiinsertLR new oldL oldR (cdr lat)))))
   (t (cons (car lat) (multiinsertLR new oldL oldR (cdr lat))))))

想必单个的版本,无非是多了一个 eq

接下来试试 multiinsertLR 的 co 版本:

(defun multiinsertLR&co (new oldL oldR lat col)
  (cond
   ((null lat)
    (funcall col (quote ()) 0 0))
   ((eq (car lat) oldL)
    (multiinsertLR&co new oldL oldR (cdr lat)
                      (lambda (newlat L R)
                        (funcall col
                                 (cons new
                                       (cons oldL newlat))
                                 (+ 1 L) R))))
   ((eq (car lat) oldR)
    (multiinsertLR&co new oldL oldR (cdr lat)
                      (lambda (newlat L R)
                        (funcall col
                                 (cons oldR
                                       (cons new newlat))
                                 L (+ 1 R)))))
   (t (multiinsertLR&co new oldL oldR (cdr lat)
                        (lambda (newlat L R)
                          (funcall col
                                   (cons (car lat)
                                         newlat)
                                   L R))))))
(multiinsertLR&co 'salty 'fish 'chips '(chips and fish or fish and chips)
                  (lambda (newlat l r)
                    (cons l (cons r newlat))))

col 函数 “收集” 了 newlat 和 L 与 R 的值,传入的匿名函数使用了这三个值,生成了最后的返回值列表

evens-only*

从一个嵌套列表的某个子列表中移除所有奇数,先看 even? 函数:

(defun even? (n)
  (= (* (/ n 2) 2) n))

(even? 3)
(even? 4)

开始实现 evens-only* 函数

(defun evens-only* (l)
  (cond
   ((null l) (quote ()))
   ((atom? (car l))
    (cond
     ((even? (car l)) (cons (car l) (evens-only* (cdr l))))
     (t (evens-only* (cdr l)))))
   (t (cons (evens-only* (car l)) (evens-only* (cdr l))))))

(evens-only* '((9 1 2 8) 3 10 ((9 9) 7 6) 2))

这很简单,下面来了个复杂的需求,要求 l 中奇数的合,以及 l 中偶数的乘积。

这需要 evens-only*&co 出场了:

(defun evens-only*&co (l col)
  (cond
   ((null l) (funcall col (quote ()) 1 0))

   ((atom? (car l))
    (cond
     ((even? (car l))
      (evens-only*&co (cdr l)
                      (lambda (newl p s)
                        (funcall col
                                 (cons (car l) newl)
                                 (* (car l) p) s))))

     (t (evens-only*&co (cdr l)
                        (lambda (newl p s)
                          (funcall col
                                   newl p
                                   (+ (car l) s)))))))

   (t (evens-only*&co (car l)
                      (lambda (al ap as)
                        (evens-only*&co (cdr l)
                                        (lambda (dl dp ds)
                                          (funcall col
                                                   (cons al dl)
                                                   (* ap dp)
                                                   (+ as ds)))))))))

这里我们可以对照一下有 co 和没 co 的版本的区别,没 co 的版本,当得知 car l 是 even 时, 直接 cons 了 car l 并递归,而 co 的版本,得知 car l 时 even 时,直接递归,并且递归版本的 even-only*&co 的第二个函数中,cons 的逻辑被定义在这里。不是 even 时也类似。

而最后的 t 的情况,就是直接的递归,把全局的 al ap as ,用局部的 dl dp ds 进行 cons * 和 + 的操作。

(defun the-last-friend (newl product sum)
  (cons sum (cons product newl)))

(evens-only*&co '((9 1 2 8) 3 10 ((9 9) 7 6) 2)
                (function the-last-friend))

keep-looking

这个函数的逻辑有点迷,它有三个参数, a sorn lat

它的意思是,查找 lat 中的第 sorn 个元素,如果它是个数字,就查找 lat 中位置是这个数字的元素,直到不是数字,那就和 a 对比,如果相同就返回 true

根据上面的描述已经可以知道递归的点在哪里了

(defun keep-looking(a sorn lat)
  (cond
   ((numberp sorn) (keep-looking a (pick sorn lat) lat))
   (t (eq sorn a))))

(keep-looking `caviar 7 `(6 2 4 caviar 5 7 3))

不过这个递归的点和之前的都不同,之前的递归都有一个 “方向”, 比如空列表或0, 但这次的递归,每次参数的变化都是不定的。

而且这个函数不一定都能得到结果,可能会无限循环,这样的函数叫 偏函数,对应的是之前的 全函数

shift

对 pair 参数,将 pair 的第一个构成的第二部分移进第二个构成,来构建出一个新的 pair

(defun shift (pair)
  (build (first (first pair))
         (build (second (first pair))
                (second pair))))

(shift `((a b) c))
(shift `((a b) (c d)))

align

shift 的支持嵌套版本

(defun align (pora)
  (cond
   ((atom? pora) pora)
   ((a-pair? (first pora))
    (align (shift pora)))
   (t (build (first pora)
             (align (second pora))))))

(align '((a b) (c d)))
(align '((a (b c))(d e)))

length*

统计 shift 参数中原子数量

(defun length* (pora)
  (cond
   ((atom pora) 1)
   (t (+ (length* (first pora)) (length* (second pora))))))

(length* '((a b) (c d)))
(length* '((a (b c))(d e)))

weight*

(defun weight* (pora)
  (cond
   ((atom? pora) 1)
   (t (+ (* (weight* (first pora)) 2) (weight* (second pora))))))

(weight* '(a b)) ;;3
(weight* '((a b) c)) ;;7
(weight* '(a (b c))) ;;5
(weight* '((a b) (c d))) ;;9
(weight* '((a (b c))(d e))) ;;13

加上了权重,把元素 “取出来” 的分数是2, 留下的只算 1

shuffle

(defun shuffle (pora)
  (cond
   ((atom? pora) pora)
   ((a-pair? (first pora))
    (shuffle (revpair pora)))
   (t (build (first pora) (shuffle (second pora))))))

(shuffle '(a (b c)))
(shuffle '(a b))
(shuffle '((a b)(c d)))

lambda length

这里特别复杂,先从最基本的开始,就是之前实现过的 length 函数

(defun length(l)
  (cond
   ((null l) 0)
   (t (+ 1 (length (cdr l))))))

(length `())
(length `(a))
(length `(a b))

重新回顾一下,这个 length 函数会不断的调用自己,当然每次调用自己 l 都会 “短一点”. 最后直到 l 是 null 的情况,返回一个确定的 0

下面看看这个函数:

(defun eternity (x)
  (eternity x))

它会不断的调用自己,当然不会有尽头,所以不要去执行它 …

现在我们改造一下 length 函数:

(defun length(l)
  (cond
   ((null l) 0)
   (t (+ 1 (eternity (cdr 1))))))

(length `())
(length `(a))

把本来要递归调用自己 (length) 的最后一行,改成了调用 eternity 函数。

这样一来,造成的结果就是,目前的 length 函数只能处理 l 是 null 的情况了,成为了一个偏函数。

一旦 l 的长度大于 0, 就没法得到结果。

下面我们把 defun 去掉,让它不能被命名

((lambda (l)
   (cond
    ((null l) 0)
    (t (+ 1 (eternity (cdr l))))))
 (quote ()))

熟悉 JavaScript 的同学对这种写法一定不陌生,定义一个匿名函数并立刻执行。

因为后面我们还要用到它,可以在心里给它一个名字 length0

接下来,我们要尝试一下编写一个匿名函数,它可以判断包含一个及一下数量元素的列表的长度:

((lambda (l)
   (cond
    ((null l) 0)
    (t (+ 1 (length0 (cdr l))))))
 `(a))

这里先缓一下,因为太长了,我们用了心里默念的 length0 函数,接下来,把 length0 替换掉:

((lambda (l)
   (cond
    ((null l) 0)
    (t (1+

        ((lambda (l)
           (cond
            ((null l) 0)
            (t (1+ (eternity (cdr l))))))
         (cdr l))

        ))))
 `(a))

这里的替换,可以发现除了复制粘贴以外,最后的立即调用的部分,我们也使用 (car l), 这里不要漏掉。另外最后也使用 eternity 函数处理超出范围的情况(其实也没处理。。。)

依次类推,试试看匿名版的 length2

((lambda (l)
   (cond
    ((null l) 0)
    (t (1+

        ((lambda (l)
           (cond
            ((null l) 0)
            (t (1+

                ((lambda (l)
                   (cond
                    ((null l) 0)
                    (t (1+ (eternity (cdr l))))))
                 (cdr l))

                ))))
         (cdr l))

        ))))
 `(a b))

相比 length1 这次,我们又”加深”了一层,把之前的 eternity 的地方又用 lambda 替换了。

可见,只要愿意,这个套娃可以一直继续下去,如果要处理的情况是有限的,倒也不是不可以,但我觉得一定有更好的通用的办法。

再次观察这个函数,所有 lambda 开头的部分都差不多,之前已经试过了,可以把函数作为参数传入其他函数的,那么我们可以试试把它抽出来。

((lambda (length)
   (lambda (l)
     (cond
      ((null l) 0)
      (t (+ 1 (funcall length (cdr l)))))))
 (function eternity))

这里我们创建了一个类似工厂的函数,它生成了一个 length0 的函数(返回的函数可以和上面的 lenth0 对照一下,是一样的),我们可以这样调用它

(funcall
 ((lambda (length)
    (lambda (l)
      (cond
       ((null l) 0)
       (t (+ 1 (funcall length (cdr l))))
       ))) (function eternity))

 (quote ()))

再试试 length1

((lambda (length)
   (lambda (l)
     (cond
      ((null l) 0)
      (t (+ 1 (funcall length (cdr l)))))))

 ((lambda (length)
    (lambda (l)
      (cond
       ((null l) 0)
       (t (+ 1 (funcall length (cdr l)))))))
  (function eternity)))

上半部分完全一致,区别就是最后调用时传入的函数 eternity, 变为了另一个 length0, 这样一来,最终生成的函数就可以支持 0 和 1 两种情况了,不信试试:

(funcall

 ((lambda (length)
    (lambda (l)
      (cond
       ((null l) 0)
       (t (+ 1 (funcall length (cdr l)))))))

  ((lambda (length)
     (lambda (l)
       (cond
        ((null l) 0)
        (t (+ 1 (funcall length (cdr l)))))))
   (function eternity)))

 `(a))

这样一来,写出能生成 length2 的函数也没问题了:

((lambda (length)
   (lambda (l)
     (cond
      ((null l) 0)
      (t (+ 1 (funcall length (cdr l)))))))

 ((lambda (length)
    (lambda (l)
      (cond
       ((null l) 0)
       (t (+ 1 (funcall length (cdr l)))))))

  ((lambda (length)
     (lambda (l)
       (cond
        ((null l) 0)
        (t (+ 1 (funcall length (cdr l)))))))
   (function eternity))))

第一部分不变,传入的匿名函数就是剩下的部分,调用试试:

(funcall

((lambda (length)
     (lambda (l)
       (cond
        ((null l) 0)
        (t (+ 1 (funcall length (cdr l)))))))

   ((lambda (length)
      (lambda (l)
        (cond
         ((null l) 0)
         (t (+ 1 (funcall length (cdr l)))))))

    ((lambda (length)
       (lambda (l)
         (cond
          ((null l) 0)
          (t (+ 1 (funcall length (cdr l)))))))
     (function eternity))))

`(a b))

可是这样做似乎又走上了套娃的老路,这个函数还是会无限的膨胀,到底如何才能去掉这些模板呢?

回顾一下,其实我们有了一些进步了,一开始的膨胀是 lambda 内部代码的膨胀,而现在,膨胀被限定在了传入参数中。

顺着这个思路,我们试试写个函数 mk-length,来生成用于传入的函数参数。

((lambda (mk-length)
   (funcall mk-length (function eternity)))

 (lambda (length)
   (lambda (l)
     (cond
      ((null l) 0)
      (t (+ 1 (funcall length (cdr l))))))))

执行的结果和第一版的 length0 一致,函数 eternity 现在会作为参数 length 被传入下半部分的函数,最后的结果就是之前的 length0, 执行试试:

(funcall
 ((lambda (mk-length)
    (funcall mk-length (function eternity)))

  (lambda (length)
    (lambda (l)
      (cond
       ((null l) 0)
       (t (+ 1 (funcall length (cdr l))))))))

 (quote ()))

那么按照这个写法, length2 呢?

((lambda (mk-length)
   (funcall mk-length
            (funcall mk-length (function eternity))))

 (lambda (length)
   (lambda (l)
     (cond
      ((null l) 0)
      (t (+ 1 (funcall length (cdr l))))))))

最里面的 mk-length 会生成一个 length0, 然后我们知道要生成 length1 需要的就是 length0, 因此只要再包一个 mk-length 就可以生成 length1 了。试试:

(funcall
 ((lambda (mk-length)
    (funcall mk-length
             (funcall mk-length (function eternity))))

  (lambda (length)
    (lambda (l)
      (cond
       ((null l) 0)
       (t (+ 1 (funcall length (cdr l))))))))

 `(a))

好了,后面的情况可以想像了,只要不停的嵌套 mk-length 就可以生成更多的 lengthN 方法,目前的情况比起之前的膨胀方式要优雅一些了。

所以现在的目标是要实现自动生成无穷多的 mk-length 方法,这不禁让人想到了 eternity 这个函数。

等等,再看一遍第一个 mk-length 函数:

(lambda (mk-length)
  (funcall mk-length (function eternity)))

要生成无穷的 mk-length 函数,那就把 mk-length 函数传给 mk-length 函数啊。。。

((lambda (mk-length)
   (funcall mk-length mk-length))

 (lambda (mk-length)
   (lambda (l)
     (cond
      ((null l) 0)
      (t (+ 1 (funcall mk-length (cdr l))))))))

这样一来它就像一个代码生成器一样,会一直生成嵌套的最内层的那段 lambda, 回到了第一版的最复杂的膨胀方式了。。。 吗?

(funcall
  ((lambda (mk-length)
     (funcall mk-length mk-length))

   (lambda (mk-length)
     (lambda (l)
       (cond
        ((null l) 0)
        (t (+ 1 (funcall mk-length (cdr l))))))))
(quote ()))

空列表是可以的,再试试?

(funcall
  ((lambda (mk-length)
     (funcall mk-length mk-length))

   (lambda (mk-length)
     (lambda (l)
       (cond
        ((null l) 0)
        (t (+ 1 (funcall mk-length (cdr l))))))))
(quote (a)))

这样就不行了,看来还是处于 length0 的情况。

关键就是最后一行的 mk-length 还是一个高阶函数的状态,没法被调用以生成函数。

(funcall
 ((lambda (mk-length)
    (funcall mk-length mk-length))
  (lambda (mk-length)
    (lambda (l)
      (cond
       ((null l) 0)
       (t (1+ (funcall
               (funcall mk-length (function eternity))
               (cdr l))))))))
 (quote (a)))

我们试着传入 eternity, 那就是 length1 的情况了。没法处理大于 1 的输入。

因为显示调用 eternity 相当于之前版本的放弃治疗情况。

为了让它能无限套娃下去,就应该这么做:

(funcall

 ((lambda (mk-length)
    (funcall mk-length mk-length))

  (lambda (mk-length)
    (lambda (l)
      (cond
       ((null l) 0)
       (t (+ 1 (funcall
                (funcall mk-length mk-length)
               (cdr l))))))))

 (quote (a b c)))

再次让 mk-length 调用 mk-length 自身!!!

欣赏一下这个可以工作的 mk-length 函数:

((lambda (mk-length)
   (funcall mk-length mk-length))

 (lambda (mk-length)
   (lambda (l)
     (cond
      ((null l) 0)
      (t (+ 1 (funcall
               (funcall mk-length mk-length)
               (cdr l))))))))

重构一下,毕竟我们需要的是 length 函数,我们需要一个切入点来放置 length

这里的方式有点跳跃,就是从 mk-length mk-length 这里切入,加入一个参数 x

(funcall
 ((lambda (mk-length)
    (funcall mk-length mk-length))
  (lambda (mk-length)
    (lambda (l)
      (cond
       ((null l) 0)
       (t (+ 1
           ((lambda (x)
              (funcall (funcall mk-length mk-length) x))
            (cdr l))))))))
 '(1 2 3 4 5 6))

这有点类似数学公式中的 a + b = c + d 所以 a + b + x = c + d + x

既然 mk-length mk-length 会返回一个函数,所以多加个 x 也不影响。。。

这样一来,我们可以抽取出一个 lambda

(funcall

 ((lambda (mk-length)
    (funcall mk-length mk-length))

  (lambda (mk-length)
    ((lambda (length)
       (lambda (l)
         (cond
          ((null l) 0)
          (t (+ 1 (funcall length (cdr l)))))))
     (lambda (x)
       (funcall (funcall mk-length mk-length) x)))))

 '(1 2 3 4 5 6))

因为 length 函数必然需要一个参数 l, 因此一开始先找了 x 替代,然后把 mk-length mk-length 的结果作为参数,这是重构的思路。

接着,我们把代码整个外面在包一个 lambda, 只接收一个参数 le, 为了让 mk-length 退居二线, 更重要的是把 lambda length 抽出来。

(funcall

 ((lambda (le)

    ((lambda (mk-length)
       (funcall mk-length mk-length))

     (lambda (mk-length)
       (funcall le (lambda (x)
                     (funcall (funcall mk-length mk-length) x))))))

  (lambda (length)
    (lambda (l)
      (cond
       ((null l) 0)
       (t (1+ (funcall length (cdr l))))))))

 '(1 2 3 4 5 6))

最后这个 lambda 我们之前实现过,这里贴出来:

((lambda (mk-length)
   (funcall mk-length (function eternity)))

 (lambda (length)
   (lambda (l)
     (cond
      ((null l) 0)
      (t (+ 1 (funcall length (cdr l))))))))

最后把 lambda (length) 那段分离出来,剩下的代码就是去掉了“业务逻辑”的部分:

(lambda (le)
  ((lambda (mk-length)
     (funcall mk-length mk-length))
   (lambda (mk-length)
     (funcall le (lambda (x)
                   (funcall (funcall mk-length mk-length) x))))))

把通用的核心逻辑的 mk-length 改个名字,因为它实际上根本不限于 make length, 再取个名字,就叫 Y 吧:

(defun Y (le)
  ((lambda (f) (funcall f f))
   (lambda (f)
     (funcall le (lambda (x)
                   (funcall (funcall f f) x))))))

这就是应用序Y组合子 !!!

(funcall (Y (lambda (length)
              (lambda (l)
                (cond
                 ((null l) 0)
                 (t (+ 1 (funcall length (cdr l))))))))
         '(1 2 3 4 5 6))

lookup-in-entry

entry 是列表组成的 pair, 第一个列表是 set, 两个列表长度必须相等。

这个函数就是给定一个 name, 找到第一个 set 中相同的名字,返回后一个 set 对应位置的值。

需要注意,还有一个 entry-f, 这个参数是个函数,如果找不到 name, 就会执行 entry-f.

这里可以理解为回调函数,但我觉得书中的理由更好:为了知道没有找到 name 对应的值时应该怎么办。

(defun lookup-in-entry (name entry entry-f)
  (lookup-in-entry-help name
                        (first entry)
                        (second entry)
                        entry-f))

(defun lookup-in-entry-help (name names values entry-f)
  (cond
   ((null names)
    (funcall entry-f name))
   ((eq (car names) name)
    (car values))
   (t (lookup-in-entry-help name
                            (cdr names)
                            (cdr values)
                            entry-f))))

(lookup-in-entry 'entree
                 '((appetirze entree beverage)
                   (pate boeuf vin)) (function print))

(lookup-in-entry 'dessert
                 '((appetirze entree beverage)
                   (pate boeuf vin))
                 (lambda (name)
                   (cons name '( not found))))

extend-table

把一个 entry 添加到一个 table 的头部

(defun extend-table (entry table)
  (cons entry table))

(extend-table '((a b c) (x y z)) '(((i j k) (l m n))))

lookup-in-table

table 是由 entry 组成的列表

(defun lookup-in-table (name table table-f)
  (cond
   ((null table) (funcall table-f name))
   (t (lookup-in-entry name (car table)
                       (lambda (name)
                         (lookup-in-table name
                                          (cdr table)
                                          table-f))))))

(lookup-in-table 'entree
                 '(((entree dessert)
                    (spaghetti spumoni))
                   ((appetizer entree beverage)
                    (food tastes good)))
                 (function print))

简单的递归,由于可以利用之前的 lookup-in-entry 的函数,编写起来还是很容易的。

(lookup-in-table 'entree
                 '(((entree dessert)
                    (spaghetti spumoni))
                   ((appetizer entree beverage)
                    (food tastes good)))
                 (function print))

取的是第一个符合条件的。

expression-to-action

value 函数应该能根据传入的表达式的类型,使用相关的动作。

我们要先实现一个函数可以得到表达式对应的动作。

(defun expression-to-action (e)
  (cond
   ((atom? e) (atom-to-action e))
   (t (list-to-action e))))

(defun atom-to-action (e)
  (cond
   ((numberp e) (function *const))
   ((eq e t) (function *const))
   ((eq e nil) (function *const))
   ((eq e (quote cons)) (function *const))
   ((eq e (quote car)) (function *const))
   ((eq e (quote cdr)) (function *const))
   ((eq e (quote null)) (function *const))
   ((eq e (quote eq)) (function *const))
   ((eq e (quote atom?)) (function *const))
   ((eq e (quote zerop)) (function *const))
   ((eq e (quote add1)) (function *const))
   ((eq e (quote sub1)) (function *const))
   ((eq e (quote numberp)) (function *const))
   (t (function *identifier))))

(defun list-to-action (e)
  (cond
   ((atom? (car e))
    (cond
     ((eq (car e) (quote quote)) (function *quote))
     ((eq (car e) (quote lambda)) (function *lambda))
     ((eq (car e) (quote cond)) (function *cond))
     ((eq (car e) (quote function)) (atom-to-action (second e)))
     (t (function *application))))
   (t (function *application))))

expression-to-action 最简单,判断参数是否是 atom 并调用下面两个函数。

atom-to-action 中列出了我们目前见过的所有 *const, 剩下的都是 *identifier

list-to-action 中列出了我们目前见过的所有 *quote *lambda *cond * application

下面是一些测试:


(list-to-action '(lambda (x y) (cons x y)))
                                        ;*lambda

(list-to-action '(function car))
                                        ;*const

(list-to-action '(function first))
                                        ;*identifier

(atom-to-action 'car)
                                        ;*const

(list-to-action '((lambda (nothing)
                    (cons nothing (quote ())))
                  (quote
                   (from nothing comes something))))
                                        ;*application


(list-to-action '((lambda (nothing)
                    (cond
                     (nothing (quote something))
                     (t (quote nothing))))
                  t))
                                        ;*application

这些测试包含了 6 种不同的类型

value meaning

有了表达式和对应的动作,我们可以定义 value 函数了

(defun value (e)
  (meaning e (quote ())))

(defun meaning (e table)
  (funcall (expression-to-action e) e table))

这里 meaning 函数中的 table, 我们后面会给出完整的内容,这里我们暂时用 quote() 这个空值填充。

*const

针对常量的动作

(defun *const (e table)
  (cond
   ((atom? e)
    (cond
     ((numberp e) e)
     ((eq e t) t)
     ((eq e nil) nil)
     (t (build (quote primitive) e))))
   (t (build (quote primitive) (second e)))))

(*const 'car '())
                                        ;(primitive car)

(*const '(function car) '())

*const 就这几种情况,number, t 和 nil , 其他都是 primitive (原函数的)

*quote

quote 动作

(defun *quote (e table)
  (text-of e))

(defun text-of (p)
  (car (cdr p)))

*quote 就取字面意思就行了

*identifier

identifier(标识符) 需要依赖 table 才能工作

(defun *identifier (e table)
  (lookup-in-table e table (function initial-table)))

(defun initial-table (name)
  (car (quote ())))

这里这个 table 终于被调用了,最后的 initial-table 如果被调用了,那说明这个程序接收到了未知的参数。

*lambda

(defun *lambda (e table)
  (build (quote non-primitive)
         (cons table (cdr e))))

(meaning
 '(lambda (x) (cons x y))
 '(((y z) ((8) 9))))

lambda 都是 non-primitive 的, 上面例子中的值为 ( (((y z) ((8) 9))) (x) (cons x y) )

从左到右分别是: table formals body, 因此可以编写下面三个帮助函数:

(defun table-of (l)
  (car l))

(defun formals-of (l)
  (car (cdr l)))

(defun body-of (l)
  (car (cdr (cdr l))))

*cond

cond 的用法就是,对每一行, 依次判断每行条件(左边部分),如果是 false, 就继续判断, 否则就回答右边部分。


(defun evcon (lines table)
  (cond
   ((else? (question-of (car lines)))
    (meaning (answer-of (car lines)) table))
   ((meaning (question-of (car lines)) table)
    (meaning (answer-of (car lines)) table))
   (t (evcon (cdr lines) table))))

(defun else? (x)
  (cond
   ((atom? x) (eq x (quote t)))
   (t nil)))

(else? t)
(else? '(a b))

(defun question-of (p)
  (car p))

(defun answer-of (p)
  (car (cdr p)))

(defun *cond (e table)
  (evcon (cond-lines-of e) table))

(defun cond-lines-of (e)
  (cdr e))

(*cond
 '(cond (coffee klatsch) (t party))
 '(
   ((coffee) (t))
   ((klatsch party) (5 ((6))))
   ))
                                        ;5

虽然用了不少帮助方法,但整体逻辑很清楚,碰到 else (t) 直接回答右边部分,其他情况调用 meaning, 只要不是 false (nil), 就回答右边部分。 不然就递归其他 cond 的行 (line)

看例子, 这里是先分析 cond 后的两个 pair, 然后判断出对应的 action,

这里最后取的是 `klatsch , 对应 table 中的 5

evlis

返回一个列表,由每个参数的意图构成

(defun evlis (args table)
  (cond
   ((null args) (quote ()))
   (t (cons (meaning (car args) table)
            (evlis (cdr args) table)))))

*application

(defun function-of (e)
  (car e))

(defun arguments-of (e)
  (cdr e))

(defun *application (e table)
  (applyz
   (meaning (function-of e) table)
   (evlis (arguments-of e) table)))

刚才说了,函数分两种 primitive? 和 non-primitive?

(defun primitive? (l)
  (eq (first l) (quote primitive)))

(defun non-primitive? (l)
  (eq (first l) (quote non-primitive)))

最后实现 applyz (apply 关键字不能用)

(defun applyz (fun vals)
  (cond
   ((primitive? fun)
    (apply-primitive (second fun) vals))
   ((non-primitive? fun)
    (apply-closure (second fun) vals))))

(defun apply-primitive (name vals)
  (cond
   ((eq name (quote cons))
    (cons (first vals) (second vals)))
   ((eq name (quote car))
    (car (first vals)))
   ((eq name (quote cdr))
    (cdr (first vals)))
   ((eq name (quote null))
    (null (first vals)))
   ((eq name (quote eq))
    (eq (first vals) (second vals)))
   ((eq name (quote atom?))
    (:atom? (first vals)))
   ((eq name (quote zerop))
    (zerop (frist vals)))
   ((eq name (quote add1))
    (1+ (first vals)))
   ((eq name (quote sub1))
    (1- (first vals)))
   ((eq name (quote numberp))
    (numberp (first vals)))))

(defun apply-closure (closure vals)
  (meaning (body-of closure)
           (extend-table
            (new-entry (formals-of closure) vals)
            (table-of closure))))

看下具体干活的 apply-primitive, 就是根据 name 来执行对应的动作。 而 apply-closure 就是调用 meaning 函数, 第一个参数是 closure 的 body 部分, 后面的 table 是把 closure 的 formals 部分与 vals 参数组成一个新 entry, 再添加到 closure 的 table 头部。