Posted on 2008-11-18 20:41
dennis 閱讀(1107)
評論(3) 編輯 收藏
在第二個分析求值器的基礎(chǔ)上實(shí)現(xiàn)了完整的amb求值器，在drscheme選擇R5RS標(biāo)準(zhǔn)下測試通過。注意，在show details面板里將disallow redefinition of initial bindings選項(xiàng)去掉，允許重定義過程。給出完整代碼：
(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)