lisp实现自动递归---SICP不确定性计算

一、递归的需求

1. 树的遍历，我们首先需要判断当前节点是否为叶子结点，如果不是叶子结点，则需要在左右子树上递归的去遍历；

2.迷宫的出口求解问题，当前位置是否为出口，如果不是，则需要在上下左右四个方法去递归搜索；

3.在微博看到一个爱因斯坦问题，如下：

1、在一条街上，有5座房子，喷了5种颜色。 
  2、每个房里住着不同国籍的人 
  3、每个人喝不同的饮料，抽不同品牌的香烟，养不同的宠物 
  问题是：谁养鱼？ 

  提示： 
  1、英国人住红色房子 
  2、瑞典人养狗 
  3、丹麦人喝茶 
  4、绿色房子在白色房子左面 
  5、绿色房子主人喝咖啡 
  6、抽Pall Mall 香烟的人养鸟 
  7、黄色房子主人抽Dunhill 香烟 
  8、住在中间房子的人喝牛奶 
  9、 挪威人住第一间房 
  10、抽Blends香烟的人住在养猫的人隔壁 
  11、养马的人住抽Dunhill 香烟的人隔壁 
  12、抽Blue Master的人喝啤酒 
  13、德国人抽Prince香烟 
  14、挪威人住蓝色房子隔壁 
  15、抽Blends香烟的人有一个喝水的邻居 

实际上这也是一个递归（搜索）问题，只不过看上去比较复杂而已。

二、自动递归的基础-延续

递归是如此的重要，如果我们有一种方法能够简化这类问题代码的编写，获得的收益将是巨大的。

使用延续，可以让我们的代码实现自动递归，即我们只用编写代码延续的条件，递归是自动执行。

1、延续的概念

续延是在运行中被暂停了的程序：即含有计算状态的单个函数型对象。当这个对象被求值时，就会在它上
次停下来的地方重新启动之前保存下来的计算。延续可以很方便的表示挂起的进程（类比linux中处于中断或者stop状态的进程），而在非确定计算中，延续表示搜索树中的节点。

续延可以理解成是一种广义的闭包。闭包就是一个函数加上一些指向闭包创建时可见的词法变量的指针。续延则是一个函数加上一个指向其创建时所在的整个栈的指针。

2、在drracket上实践延续（具体参考onlisp-20.1)

#lang racket
(define frozen 0)
(append '(the call/cc returned)
          (list (call-with-current-continuation
                 (lambda (cc)
                   (set! frozen cc)
                   'a))))
(define froz1 0)
(define froz2 0)
(let ((x 0))
    (call-with-current-continuation
     (lambda (cc)
       (set! froz1 cc)
       (set! froz2 cc)))
    (set! x (+ 1 x))
    x)

CC表示当前的延续，是一个带有一个参数的函数，参数是什么，就返回什么，上面代码的意思就是将当前的延续保存在frozen，froz1，froz2种，然后下次就可以调用frozen/1/2， 执行当前的延续。

3、执行的结果如下

上面的代码执行结果会返回2次，这点确实比较奇怪。

4、树的遍历

(define (dft tree)
  (cond ((null? tree) '())
        ((not (pair? tree)) (write tree))
        (else (dft (car tree))
              (dft (cdr tree)))))

(define *saved* '())
(define (dft-node tree)
  (cond ((null? tree) (restart))
        ((not (pair? tree)) tree)
        (else (call-with-current-continuation
               (lambda (cc)
                 (set! *saved*
                       (cons (lambda ()
                               (cc (dft-node (cdr tree))))
                             *saved*))
                 (dft-node (car tree)))))))
(define (restart)
  (if (null? *saved*)
      'done
      (let ((cont (car *saved*)))
        (set! *saved* (cdr *saved*))
        (cont))))
(define t1 '(a (b (d h)) (c e (f i) g)))

(define (dft2 tree)
  (set! *saved* '())
  (let ((node (dft-node tree)))
    (cond ((eq? node 'done) '())
          (else (write node)
                (restart)))))

执行结果如下：

注意，dft2居然延续的是(let((node (dft2 t1))), 这点确实非常不可思议，CC保存的是整个执行栈的环境。

三、common-lisp实现延续

(defvar *actual-cont* #'values)
(define-symbol-macro *cont* *actual-cont*)
(defmacro =lambda (parms &body body) 
  `#'(lambda (*cont* ,@parms) ,@body))

(defmacro =defun (name parms &body body)
  (let ((f (intern (concatenate 'string
                                "=" (symbol-name name)))))
    `(progn
       (defmacro ,name ,parms
         `(,',f *cont* ,,@parms))
       (defun ,f (*cont* ,@parms) ,@body))))

(defmacro =bind (parms expr &body body)
  `(let ((*cont* #'(lambda ,parms ,@body))) ,expr))
    
(defmacro =values (&rest retvals)
  `(funcall *cont* ,@retvals))

(defmacro =funcall (fn &rest args)
  `(funcall ,fn *cont* ,@args))

(defmacro =apply (fn &rest args)
  `(apply ,fn *cont* ,@args))

(defparameter *paths* nil)
(defconstant failsym '@)

(defmacro choose (&rest choices)
  (if choices
      `(progn
         ,@(mapcar #'(lambda (c)
                       `(push #'(lambda () ,c) *paths*))
                   (reverse (cdr choices)))
         ,(car choices))
      '(fail)))

(defmacro choose-bind (var choices &body body)
  `(cb #'(lambda (,var) ,@body) ,choices))

(defun cb (fn choices)
  (if choices
     (progn
       (if (cdr choices)
           (push #'(lambda () (cb fn (cdr choices)))
                 *paths*))
       (funcall fn (car choices)))
     (fail)))
 
(defun fail ()
  (if *paths*
      (funcall (pop *paths*))
      failsym))

解释

(=defun add1 (x) (=values (1+ x)))

将会被展开为

(progn (defmacro add1 (x)
‘(=add1 *cont* ,x))

(defun =add1 (*cont* x)
(=values (1+ x))))

*cont*的含义是绑定到当前的延续，=value显示了当前延续的作用，将结果作为参数，直接调用当前的延续。参 数 *cont* 告 诉 那 个 由 =defun 定 义 的 函 数 对 其 返 回 值 做 什 么。

> (=defun message ()
(=values ’hello ’there))
MESSAGE
(=defun baz ()
(=bind (m n) (message)
(=values (list m n))))
BAZ
> (baz)
(HELLO THERE)
注意到 =bind 的展开式会创建一个称为 *cont* 的新变量。baz 的主体展开成:
(let ((*cont* #’(lambda (m n)
(=values (list m n)))))
(message))
然后会变成:
(let ((*cont* #’(lambda (m n)
(funcall *cont* (list m n)))))
(=message *cont*))
由于 *cont* 的新值是 =bind 表达式的代码体,所以当 message 通过函数调用 *cont* 来 “返回” 时,结果将是去求值这个代码体。尽管如此 (并且这里是关键), =bind 的主体里:
在
#’(lambda (m n)
(funcall *cont* (list m n)))
作为参数传递给 =baz 的 *cont* 仍然是可见的,所以当代码的主体求值到一个 =values 时,它将能够返回到最初的主调函数那里。所有闭包环环相扣:每个 *cont* 的绑定都包含了上一个 *cont* 绑定的闭包,它们串成一条锁链,锁链的尽头指向那个全局的值。

基于延续的自动递归

问题实践一

baker cooper fletcher miller smith分别住在一个五层公寓楼的不同层，baker不在顶层，cooper不在底层，fletcher不在顶层和底层，miller住在cooper的上面（不一定是相邻的层），smith和fletcher不在相邻的层，求他们各住在那一层。

;baker cooper fletcher miller smith
(=defun people-dwelling ()
  (choose-bind baker '(1 2 3 4 5)
    (choose-bind cooper '(1 2 3 4 5)
      (choose-bind fletcher '(1 2 3 4 5)
	(choose-bind miller '(1 2 3 4 5)
	  (choose-bind smith '(1 2 3 4 5)
	    (=values baker cooper fletcher miller smith)))))))

(defun distinct? (items)
  (cond ((null items) t)
	((member (car items) (cdr items)) nil)
	(t (distinct? (cdr items)))))

(=defun calculate ()
  (=bind (baker cooper fletcher miller smith)
      (people-dwelling)
    (if (and  
	 (distinct?  (list baker cooper fletcher miller smith))
	 (not (= baker 5))
	 (not (= cooper 1))
	 (not (= fletcher 5))
	 (not (= fletcher 1))
	 (> miller cooper)
	 (not (= (abs (- smith fletcher)) 1))
	 (not (= (abs (- fletcher cooper)) 1)))

	 (list (list 'baker baker) (list 'cooper cooper)
	       (list 'fletcher fletcher) (list 'miller miller)
	       (list 'smith smith))

	 (fail))))

结果如下：

爱因斯坦问题实践

(defmacro var-choose-choices (choices (&rest choosers) &rest body)
  (if (null choosers) 
       `(progn ,@body)
       `(choose-bind ,(car choosers) ,choices
	  (var-choose-choices ,choices ,(cdr choosers) ,@body))))

(=defun people-character ()
  (var-choose-choices '(1 2 3 4 5) 
		      (ep sp dp np gp)
		      (=values ep sp dp np gp)))

(=defun Einstein ()
  (=bind (eno sno dno nno gno)
      (people-character)
    (let ((houses (list eno    sno    dno    nno    gno)))
      (if (and 
	   (distinct? houses)
	   (= nno 1))
	  (=bind (ecolor scolor dcolor ncolor gcolor)
	      (people-character)
	    (let ((colors (list ecolor scolor dcolor ncolor gcolor)))
	      (if (and 
		   (distinct? colors)
		   (< (get-another-property 3 colors houses)
		      (get-another-property 2 colors houses))
		    (= (abs (- nno (get-another-property 5 colors houses)))
		       1)
		    (= ecolor 1))
		  (=bind (edrink sdrink ddrink ndrink gdrink)
		      (people-character)
		    (let  ((drinks (list edrink sdrink ddrink ndrink gdrink)))
		      (if (and 
			   (distinct? drinks)
			   (= ddrink 1) 
			   (= (get-another-property 3 colors drinks) 2)
			   (= (get-another-property 3 houses drinks) 3))
			  (=bind (esmoke ssomke dsmoke nsmoke gsmoke)
			      (people-character)
			    (let ((smokes (list esmoke ssomke dsmoke nsmoke gsmoke)))
			      (if (and 
				   (distinct? smokes)
				   (= (get-another-property 4 smokes drinks) 4)
				   (= gsmoke 5)
				   (= 1 (abs (- (get-another-property 3 smokes houses)
						(get-another-property 5 drinks houses))))
				   (= (get-another-property 4 colors smokes) 2))
				  (=bind (epat   spat   dpat   npat   gpat)
				      (people-character)
				    (let ((pats   (list epat   spat   dpat   npat   gpat)))
				      (if (and 
					   (distinct? pats) 
					   (= ecolor 1)
					   (= spat   1)
					   (= ddrink 1) 
					   (< (get-another-property 3 colors houses)
					      (get-another-property 2 colors houses))
					   (= (get-another-property 3 colors drinks) 2)
					   (= (get-another-property 1 smokes pats) 2)
					   (= (get-another-property 4 colors smokes) 2)
					   (= (get-another-property 3 houses drinks) 3)
					   (= nno 1)
					   (= 1 (abs (- (get-another-property 3 smokes houses)
							(get-another-property 3 pats   houses))))
					   (= 1 (abs (- (get-another-property 4 pats   houses)
							(get-another-property 2 smokes houses))))
					   (= (get-another-property 4 smokes drinks) 4)
					   (= gsmoke 5)
					   (= (abs (- nno (get-another-property 5 colors houses)))
					      1)
					   (= 1 (abs (- (get-another-property 3 smokes houses)
							(get-another-property 5 drinks houses)))))
					  (list houses colors drinks smokes pats)
					  (fail))))
				  (fail))))
				  (fail))))
			  (fail))))
		  (fail))))
	  (fail))

上面代码中e,s,d,n,g开头的单词分别代表英国人，瑞典人，丹麦人，挪威人，德国人
其中1、2、3、4、5分别代表

;1 2 3 4 5 represent
;house no 1 2 3 4 5
;red white green yellow blue
;tea coffee milk beer water
;pallmall dunhill blends bluemaster prince
;dog bird cat horse fish

代码的中间部分有些重复，把所有的条件列举了一遍，这个主要是避免条件的遗漏。

执行的结果是

养鱼的人是德国人