基于分析的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 (
4000
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放进求值器里作为一种形式--------简直神逻辑。他提出用文
b88e
中的理论可以实现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返回第二个元素，再重新执行一次。这里再重新执行一次就是回溯。为实现回溯可以把表达式的执行当作单链表一样，在当前执行的表达式里包含以后所执行的所有表达式的“指针”。另外为了在未来调用回溯实现回溯到特殊的指定位置重新执行，需要大毅力，呃不是。需要将返回点传递下去。由此得到成功继续与失败继续机制。。。。。。。。。。。到此为止了





这个好像超级赛亚人。人。。。。。。。。。。。。。。。。。。。。。。。气死我了昨天关键时刻断网了，，，，，没保存