完整的scheme amb求值器

(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  (null? procs)
        (error  " Empty sequence --ANALYZE " )
        (loop (car procs) (cdr procs)))))
(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)
                           (execution - 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)
                      (get - args (cdr aprocs)
                                env
                                ( lambda  (args fail3)
                                  (succeed (cons arg args) fail3))
                                fail2))
                    fail)))
(define (execution - 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)
            (fail)
            ((car choices)
             env
             succeed
             ( lambda ()
               ( try - next (cdr choices))))))
      ( try - next cprocs))))
(drive - loop)

        

     文章转自庄周梦蝶  ，原文发布时间2008-11-18