基于分析的amb求值器，及其分析

一下代码在mit-scheme下解释并编译通过。e并完成基本功能测试。

这个解释器在原SICP基础上加入了require和let的基本形式，，，，，

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;other Codes
(define (length items)
 (if (null? items)
     0
     (+ 1 (length (cdr items)))))
(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 'miller miller)
         (list 'smith smith))))
(define (require p)
  (if (not p) (amb)))
(define (am-element-of items)
   (require (not (null? items)))
   (amb (car items) (am-element-of (cdr items)))) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;求值器的内核部分
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;     ambeval  的定义
(define (ambeval exp env succeed fail)
   ((analyze exp) env succeed fail))
(define (analyze exp)
   (cond ((self-evaluation? exp)
          (analyze-self-evaluating exp))
         ((quoted? exp) (analyze-quoted exp))
         ((let? exp) (let->combinition (let-pairs exp)
                                       (let-body exp)))         
         ((variable? exp) (analyze-variable exp))
         ((assignment? exp) (analyze-assignment exp)) 
         ((definition? exp) (analyze-definition exp))
         ((if? exp) (analyze-if exp))
         ((lambda? exp) (analyze-lambda exp))
         ((begin? exp) (analyze-sequence (begin-actions exp)))
         ((cond? exp) (analyze (cond->if exp)))
         ((require? exp) (analyze-require exp))
         ((amb? exp) (analyze-amb exp))
         ((application? exp) (analyze-application exp))
         (else
            (error "unknwn expression type --ANLYZE" exp))))
            
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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))))
;;;;;;;;;;;;;;;
(define (let->combinition pairs body)
    (let ((let-vars (get-make-var-pairs pairs))
          (let-exps (get-make-exp-pairs pairs)))
       (analyze (make-lambda-procedure let-vars body let-exps))))
(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
               (lambda (pred-value fail2)
                  (if (true? pred-value)
                      (cproc env succeed fail2)
                      (aproc env succeed fail2)))
               fail)))) 
(define (analyze-sequence exps)
   (define (sequentially a b)
      (lambda (env succeed fail)
         (a env
            (lambda (a-value fail2)
              (display a-value)
             (b env succeed fail2))
            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))))
(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))))
(define (analyze-assignment exp)
   (let ((var (assignment-variable exp))
         (vproc (analyze (assignment-value exp))))
     (lambda (env succeed fail)
        (vproc env
               (lambda (val fail2)
                  (let ((old-value
                          (lookup-variable-value var env)))
                    (set-variable-value! var val env)
                    (succeed 'ok
                             (lambda ()
                               (set-variable-value! var 
                                                    old-value
                                                    env)
                             (fail2)))))
               fail))))
(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))))
(define (get-args aprocs env succeed fail)
    (if (null? aprocs)
        (succeed () fail)
        ((car aprocs) env
                      (lambda (arg fail2)
                         (display arg)
                         (get-args (cdr aprocs)
                                   env
                                   (lambda (args fail3)
                                      (succeed (cons arg args)
                                               fail3))
                                   fail2))
                      fail)))
(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))))
(define (analyze-amb exp)
   (let ((cprocs (map analyze (amb-choices exp))))
     (lambda (env succeed fail)
        (define (try-next choices)
          (if (null? choices)
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;changed
              (begin (display "Fail procedure was called") (fail))
              ((car choices) env
                             succeed
                             (lambda ()
                                 (try-next (cdr choices))))))
        (try-next cprocs))))
(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))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;         赋值和定义
(define (assignment? exp)
    (tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 表达式的表示
(define (require? exp) (tagged-list? exp 'require))
(define (require-predicate exp) (cadr exp))


(define (self-evaluation? exp)
   (cond ((number? exp) true)
         ((string? exp) true)
         (else false)))
(define (variable? exp) (symbol? exp))
(define (quoted? exp)
    (tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
    (if (pair? exp)
        (eq? (car exp) tag)
        false))


(define (amb? exp) (tagged-list? exp 'amb))
(define (amb-choices exp) (cdr exp))


(define (definition? exp)
    (tagged-list? exp 'define))
(define (definition-variable exp)
    (if (symbol? (cadr exp))
        (cadr exp)
        (caadr exp)))
(define (definition-value exp)
   (if (symbol? (cadr exp))
       (caddr exp)
       (make-lambda (cdadr exp)
                    (cddr exp))))


(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
     (cons 'lambda (cons parameters body)))


(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
    (if (not (null? (cdddr exp)))
        (cadddr exp)
        'false))
(define (make-if predicate consequent alternative)
    (list 'if predicate consequent alternative))




(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))      
(define (sequence->exp seq)
   (cond ((null? seq) seq)
         ((last-exp? seq) (first-exp seq))
         (else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))


(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;派生表达式
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;cond
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
    (eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
    (expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
    (if (null? clauses)
        'false
        (let ((first (car clauses))
              (rest (cdr clauses)))
          (if (cond-else-clause? first)
              (if (null? rest)
                  (sequece->exp (cond-actions first))
                  (error "ELSE clause is'nt last -- COND->IF"
                        clauses))
              (make-if (cond-predicate first)
                       (sequence->exp (cond-actions first))
                       (expand-clauses rest))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;let
(define (let? exp) 
  (tagged-list? exp 'let))
(define (let-body exp) 
 (cddr exp))
(define (let-pairs exp) (cadr exp))
(define (var-let-pair pair) (car pair))
(define (exp-let-pair pair) (cadr pair))
(define (get-make-var-pairs pairs)
  (if (not (null? pairs))
      (cons (var-let-pair (car pairs))
            (get-make-var-pairs (cdr pairs)))
      pairs))
(define (get-make-exp-pairs pairs)
  (if (not (null? pairs))
      (cons (exp-let-pair (car pairs))
            (get-make-exp-pairs (cdr pairs)))
      pairs))
(define (make-lambda-procedure vars body exps)
    (cons (cons 'lambda (cons vars body)) exps))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 求值器的数据结构
;;;;;;;;;;;;;;;;;;;;;;;;;谓词检测
(define (true? x)
   (not (eq? x false)))
(define (false? x)
   (eq? x false))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;过程的表示
(define (make-procedure parameters body env)
    (list 'procedure parameters body env))
(define (compound-procedure? p)
    (tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
;;;;;;;;;;;;;;;;;;;;;;;;;;;对环境的操作
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment ())


(define (make-frame variables values)
    (cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
    (set-car! frame (cons var (car frame)))
    (set-cdr! frame (cons val (cdr frame))))
    
(define (extend-environment vars vals base-env)
    (if (= (length vars) (length vals))
        (cons (make-frame vars vals) base-env)
        (if (< (length vars) (length vals))   
           (error "Too many arguments supplied" vars vals)
           (error "Too few arguments supplied" vars vals))))
(define (lookup-variable-value var env)
    (define (env-loop env)
       (define (scan vars vals)
          (cond ((null? vars)
                   (env-loop (enclosing-environment env)))
                ((eq? var (car vars))
                 (car vals))
                (else (scan (cdr vars) (cdr vals)))))
       (if (eq? env the-empty-environment)
           (error "Unbound variable" var)
           (let ((frame (first-frame env)))
              (scan (frame-variables frame)
                    (frame-values frame)))))
    (env-loop env))
(define (set-variable-value! var val env)
   (define (env-loop env)
       (define (scan vars vals)
          (cond ((null? vars)
                 (env-loop (enclosing-environment env)))
                ((eq? var (car vars))
                 (set-car! vals val))
                (else (scan (cdr vars) (cdr vals)))))
        (if (eq? env the-empty-environment)
            (error "Unbound variable -- SET!" var)
            (let ((frame (first-frame env)))
              (scan (frame-variables frame)
                    (frame-values frame)))))
   (env-loop env))            
(define (define-variable! var val env)
    (let ((frame (first-frame env)))
      (define (scan vars vals)
         (cond ((null? vars)
                (add-binding-to-frame! var val frame))
               ((eq? var (car vars))
                (set-car! vals val))
               (else (scan (cdr vars) (cdr vals)))))
      (scan (frame-variables frame)
            (frame-values frame))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;作为程序运行这个求值器
(define primitive-procedures
    (list (list 'car car)
          (list 'cdr cdr)
          (list 'list list)
          (list 'eq? eq?)
          (list 'cons cons)
          (list 'null? null?)
          (list '+ +)
          (list '- -)
          (list '* *)
          (list '/ /)
          (list '< <)
          (list '> >)
          (list '= =)
          (list 'not not)
          (list 'abs abs)
          (list 'cadr cadr)
          (list 'caddr caddr)
          (list 'display display)
          (list 'newline newline)
          (list 'map map)))


(define (primitive-procedure-names)
   (map car 
        primitive-procedures))
(define (primitive-procedure-objects)
   (map (lambda (proc) (list 'primitive (cadr proc)))
        primitive-procedures))


(define (setup-environment)
    (let ((initial-env
            (extend-environment (primitive-procedure-names)
                                (primitive-procedure-objects)
                                the-empty-environment)))
     (define-variable! 'true true initial-env)
     (define-variable! 'false false initial-env)
     initial-env))
(define the-global-environment (setup-environment))


(define (primitive-procedure? proc)
    (tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))


(define (apply-primitive-procedure proc args)
   (apply
       (primitive-implementation proc) args))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;驱动循环
(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
                        (lambda (val next-alternative)
                           (announce-output output-prompt)
                           (user-print val)
                           (internal-loop next-alternative))
                        (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))))
(define (prompt-for-input string)
   (newline) (newline) (display string) (newline))
(define (announce-output string)
    (newline) (display string) (newline))
(define (user-print object)
   (if (compound-procedure? object)
       (display (list 'compound-procedure
                      (procedure-parameters object)
                      (procedure-body object)))
       (display object)))              
(define the-global-environment (setup-environment))


(driver-loop)   
        
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;test 

现在开始直接分析这个求值器了，

   require和let形式是自己写的。就懒得分析了。这个求值器是在原来分析求值器的基础上修改的。   amb求值器是为了实现非确定性计算而设计的，这使得简单的描述一个问题就能得到结果成为可能。如：（在所有自然数里，找到所有的素数）这本身是问题的描述，但也可以成为解决问题的全部内容。为了实现这样的形式，（in all z*，require prime z，list z），即可找到第一个素数，但为了找到全部解，提供一个try-again使得求值器能按要求解出表达式的解（就像解方程一样，自动解方程），其他部分继承了分析求值器的功能。这些是amb求值器的设计目标。

     amb形式能有返回一个表中的任意一个值。require能够使amb的值为满足要求的第一个值。有了这两个形式就能实现非确定性计算（原来是约翰。麦卡锡提出的非确定性程序设计的amb思想，他还是lisp之父，可惜2011年死了。这么牛的程序员怎么就死了。不知道他老了的时候手指还好不好使。还是专心去培养后人了。去看了他的文章《A BASIS FOR A MATHEMATICAL THEORY OF COMPUTATION》........结果没看完，计算理论什么的简直难爆了）看了下论文中关于ambguous Function的描述。amb并不是一个function所以把amb放进求值器里作为一种形式--------简直神逻辑。他提出用文中的理论可以实现amb形式，但没说是怎么实现。怎么看那篇文章都是在讲lisp的数学理论什么的。 而lisp的创立时间也和文章的时间差不多，约翰麦卡锡在刚创立语言之初就能预见到lisp可以实现非确定性计算吗？，这里虽然是scheme但也是lisp变来的。他怎么可能有这么强的先见性。大牛的思维简直吓死人。。。 已瞎））算了，后人实现了amb形式。从他论文那里看来我之前的分析是错误的。amb形式和require形式不是独立的。require是由amb形式所实现的（而事实上SICP上就是这么实现的。写道这里麦卡锡简直是大魔神，）既然这样我就require以amb表示。根据论文里

ult（n）=（n=0->0,T->ult(less (n)))  应该用条件语句实现（if （not p） procedure）。这种形式这里的procedure要满足能够减少amb的可能值，并能判断下一个amb的值是否满足条件，还要能提供递归下去。在sicp中提供一种成功继续与失败继续的过程。而（amb）过程会直接执行失败继续。这个失败继续是由调用（amb） 的成功继续传递过来。这个成功继续在if语句里是predicate的成功继续。（这个地方的分析，成功继续与失败继续的机制目前还是空穴来风，不知道作者怎么想的，之后再来解决，先继续下去）

而predicate包含以amb值为参数的过程基于分析求值器的ambeval会分析predicate，amb参数会最后被分析，最先被求值。这样amb能构造出失败继续，选择下一个值传给succeed继续下去，再求一次if过程。我突然想起来还有点测试代码没去掉，到时候会有乱七八糟的东西打印出来。现在开始考虑前面的analyze过程，对比之前分析求值器，相同的地方就不分析了，略微的改变也不分析。为了实现前面失败继续的回溯机制。分析表达式是要注意顺序，表达式的分析执行总是由内向外的，这样在调用fail继续的时候才能回溯到之前的地方在求值一次。（要注意的是我们构造自己的失败继续的地方，只有analyze-amb ，analyze-assignment，和最初的失败继续。其他的分析只是将上层的fail简单的传递到下层成功继续里，因为其他表达式并不需要回溯。调用失败继续的有（amb），driver-loop的最初失败继续。以及（try-again）过程。回溯机制就到这里。考虑有多个amb表达式嵌套的情况下再执行后调用失败继续会发生什么-------分析amb过程，以一个succed继续和失败继续开始执行。若分析到第二个amb表达式，它接收到的fail继续是第一个amb过程自己定义的，而succeed继续与第一个相同，以此类推，知道最后一个amb表达式，其返回一不包含amb的表达式的值转给succeed，向外层执行。解决这种问题不能跟踪程序，而是只需要知道下一步该去哪。和前一步。并且知道analyse总能做到令人满意的形式。想模块化程序设计一样。但也不同。amb求值器的运行机理就到这里了。

最后还有一个之前没解决的问题，为何要使用成功继续与失败继续的求值器来实现非确定性求值？

   使用求值器的原因之前说过，amb不能实现为函数，所以在求值器里实现为一种形式；

 amb表达式会先返回第一个元素，还需提供一种方法使得，一定情况下是amb返回第二个元素，再重新执行一次。这里再重新执行一次就是回溯。为实现回溯可以把表达式的执行当作单链表一样，在当前执行的表达式里包含以后所执行的所有表达式的“指针”。另外为了在未来调用回溯实现回溯到特殊的指定位置重新执行，需要大毅力，呃不是。需要将返回点传递下去。由此得到成功继续与失败继续机制。。。。。。。。。。。到此为止了这个好像超级赛亚人。人。。。。。。。。。。。。。。。。。。。。。。。气死我了昨天关键时刻断网了，，，，，没保存