完整的scheme amb求值器

    在第二个分析求值器的基础上实现了完整的amb求值器，在drscheme选择R5RS标准下测试通过。注意，在show details面板里将disallow redefinition of initial bindings选项去掉，允许重定义过程。给出完整代码：

<!---->(define apply-in-underlying-scheme apply)
(define (amb-eval exp env succeed fail)
  ((analyze exp) env succeed fail))
(define (analyze exp)
  (cond ((self-evaluating? exp)
         (analyze-self-evaluating exp))
        ((quoted? exp)
         (analyze-quoted 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)))
        ((let? exp) (analyze (let->combination exp)))
        ((amb? exp) (analyze-amb exp))
        ((unless? exp) (analyze (unless->if exp)))
        ((application? exp)(analyze-application exp))
        (else
           (error "Unknown expression type--ANALYZE" exp))))
(define (self-evaluating? exp)
  (cond ((number? exp) #t)
        ((string? exp) #t)
        (else
           #f)))
(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)
      #f))
(define (assignment? exp)
  (tagged-list? exp 'set!))
(define (assignment-variable exp)
  (cadr exp))
(define (assignment-value exp)
  (caddr 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? exps) (null? (cdr exps)))
(define (first-exp exps) (car exps))
(define (rest-exps exps) (cdr exps))
(define (make-begin seq) (cons 'begin seq))
(define (sequence->exp seq)
  (cond ((null? seq) seq)
        ((last-exp? seq) (first-exp seq))
        (else
           (make-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))
(define (let? exp)
  (tagged-list? exp 'let))
(define (make-define var parameters body)
  (list 'define (cons var parameters) body))
(define (let->combination exp)
  (if (symbol? (cadr exp))
      (let ((var (cadr exp))
            (vars (map car (caddr exp)))
            (vals (map cadr (caddr exp)))
            (pairs (caddr exp))
            (body (cdddr exp)))
        (cons (make-lambda vars (list (make-define var vars body) body)) vals))
      (let ((vars (map car (cadr exp)))
            (vals (map cadr (cadr exp)))
            (body (cddr exp)))
              (cons (make-lambda vars body) vals))))
(define (cond? exp)
  (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clauses? clause)
  (eq? (cond-predicate clause) 'else))
(define (cond-extended-clauses? clause)
  (and (> (length clause) 2) (eq? (cadr clause) '=>)))
(define (extended-cond-test clause)
  (car clause))
(define (extended-cond-recipient clause)
  (caddr clause)) 
(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)))
        (cond ((cond-else-clauses? first)
                (if (null? rest)
                    (sequence->exp (cond-actions first))
                    (error "else clause is not LAST" clauses)))
              ((cond-extended-clauses? first)
               (make-if
                   (extended-cond-test first)
                    (list
                      (extended-cond-recipient first)
                      (extended-cond-test first))
                      (expand-clauses rest)))
              (else
               (make-if (cond-predicate first)
                        (sequence->exp (cond-actions first))
                        (expand-clauses rest)))))))
(define (unless? exp)
  (tagged-list? exp 'unless))
(define (unless->if exp)
  (make-if (cadr exp) (cadddr exp) (caddr exp)))
(define (true? exp)
  (or (eq? exp 'true) exp))
(define (false? exp)
  (or (eq? exp 'false) exp))
(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 (amb? exp)
  (tagged-list? exp 'amb))
(define (amb-choices exp) (cdr exp))
(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 f)
  (car f))
(define (frame-values f)
  (cdr f))
(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? (car vars) var)
             (set-car! vals val))
            (else
               (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame)
          (frame-values frame))))
(define (primitive-procedure? p)
  (tagged-list? p 'primitive))
(define (primitive-implementation proc) (cadr proc))
(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 'assoc assoc)
        (list 'cadr cadr)
        (list 'cadr 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 #t initial-env)
    (define-variable! 'false #f initial-env)
    initial-env))
(define the-global-environment (setup-environment))
(define (apply-primitive-procedure proc args)
  (apply-in-underlying-scheme (primitive-implementation proc) args))
(define input-prompt ";;; AMB-Eval input:")
(define out-prompt ";;; AMB-Eval value:")
(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)
                     '<procedure-env>))
      (display object)))
(define (drive-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 ")
            (amb-eval input the-global-environment
                    (lambda(val next-alternative)
                      (announce-output out-prompt)
                      (user-print val)
                      (internal-loop next-alternative))
                    (lambda()
                      (announce-output
                       ";;;There are no more values of")
                      (user-print input)
                      (drive-loop)))))))
  (internal-loop
   (lambda()
     (newline)
     (display ";;;There is no current problem")
     (drive-loop))))
   
    
;接下来是分析过程
(define (analyze-self-evaluating exp)
  (lambda(env succeed fail) (succeed exp fail)))
(define (analyze-variable exp)
  (lambda(env succeed fail) (succeed (lookup-variable-value exp env) fail)))
(define (analyze-quoted exp)
  (let ((qval (text-of-quotation exp)))
    (lambda(env succeed fail) (succeed qval 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-definition exp)
  (let ((var (definition-variable exp))
        (vproc (analyze (definition-value exp))))
    (lambda(env succeed fail)
      (vproc env
             (lambda(vproc-value fail2)
                   (define-variable! var vproc-value env)
                   (succeed 'ok fail2))
             fail))))
(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-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 (analyze-sequence exps)
  (define (sequentially proc1 proc2)
    (lambda(env succeed fail)
        (proc1 env
               (lambda(a-value fail2) (proc2 env succeed fail2))
               fail)))
  (define (loop first-proc rest-proc)
    (if (null? rest-proc)
        first-proc
        (loop (sequentially first-proc (car rest-proc))
              (cdr rest-proc))))
  (let ((procs (map analyze exps))
        )
    (if