完整的amb求值器
由于前两小节的习题需要amb-evaluator去测试，所以需要先把4.3.3中的求值器实现。这里给出我写的，可以在学4.3.1和4.3.2暂时用来做习题。
amb-eval相比之前两个求值器要复杂，郁闷的看了n遍。其中比较麻烦的事情就是succeed和fail过程传来传去，还有succeed的调用也让人一上来觉得不太适应。
所谓的succeed和fail，可以理解为运行过程中的两个分叉，之前接触的eval-apply循环、lazy-eval可以看做是全程succeed的情况。相类似的analyze-self-evaluating/analyze-quoted等过程，都只是传递succeed和fail过程而涉及不到运行的分叉。
处理if语句时，由于if-predict中可能有amb语句(可以造成fail)，所以要进行判断：如果if-predict是"成功的"，那么分情况考虑if-consequent或者if-alternative；若是"失败"的，就调用fail过程。书中analyze-if中的fail2只是为了在名字上与fail区分开来，实际的值也是fail，而不会存在两个不同的fail过程。
set!过程又与上面不同，由于需要消除赋值带来的副作用，所以求值assignment-value的fail过程和外层set!的fail过程是不同的，不可以像if那样直接调用过来。
个人感觉最难理解的是过程应用中的get-args过程。它的作用大概就是把apply的参数值提取出来(由于这些值都是(lambda(env succeed fail)(...)之类的东西，所以需要另写get-args而不是直接用map))。其中递归调用get-args时，增量是get-args的参数succeed的val部分。可以这么看: succeed过程实际是(lambda(args fail) (succeed args fail))，仔细观察程序可以发现，递归调用中的succeed部分是这样的：(lambda(args fail) (succeed (cons arg args) fail))，增加的那个arg就是提取出来的value。
相关的analyze-application和execute-application相对容易，理解这部分可以通过人肉追踪一个简单的过程应用来完成。比如(+ 1 (amb 2 3))。 (ps. 这里如果用Drscheme的调试功能会比较郁闷，因为绝大多数想知道的数据和过程都是(#procedure)...)
接下来的amb过程是整个求值器中最独特最独特的部分，但是原理并不复杂，有点类似analyze-sequence。
直接复制以下代码，运行(driver-loop)即可：
;;----------------------------------------------------------
;;-----------procedures for put--------------
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define false #f)
(define true #t)
;;----------------------------------------------------------
(define false #f)
(define true #t)
(define (true? x) (not (eq? x false)))
(define (false? x) (eq? x false))
;----------------------------------------------
(define (ambeval exp env succeed fail)
((analyze exp) env succeed fail))
;--------analyze----------------
(define (analyze exp)
(cond ((self-evaluating? exp) (analyze-self-evaluating exp))
((variable? exp) (analyze-variable exp))
((get 'analyze (get-tag exp))
((get 'analyze (get-tag exp)) exp))
((application? exp) (analyze-application exp))
(else (error "Unknownd expression type---ANALYZE" exp))))
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
(else false)))
(define (variable? exp) (symbol? exp))
;---amb-eval-procs---
(define (analyze-self-evaluating exp)
(lambda(env succeed fail) (succeed exp fail)))
(define (analyze-quoted exp)
(let ((qval (text-of-quotation exp)))
(lambda(exp succeed fail) (succeed qval fail))))
(define (text-of-quotation exp) (cadr exp))
(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 (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p) (tagged-list? p 'procedure))
(define (procedure-parameters proc) (cadr proc))
(define (procedure-body proc) (caddr proc))
(define (procedure-environment proc) (cadddr proc))
(define (analyze-sequence exps)
(define (sequentially a b)
(lambda(env succeed fail)
(a env
(lambda (a-value fail2)
(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))))
;;======and or=======
(define (analyze-and exp)
(define (helper clauses)
(if (null? clauses)
(lambda(env succeed fail)
(succeed true fail))
(lambda (env succeed fail)
((analyze (car clauses)) env
(lambda (val fail2)
(if (false? val)
(succeed false fail2)
((helper (cdr clauses)) env succeed fail2)))
fail))))
(helper (cdr exp)))
(define (analyze-or exp)
(define (helper clauses)
(if (null? clauses)
(lambda(env succeed fail)
(succeed false fail))
(lambda (env succeed fail)
((analyze (car clauses)) env
(lambda (val fail2)
(if (true? val)
(succeed true fail2)
((helper (cdr clauses)) env succeed fail2)))
fail))))
(helper (cdr exp)))
;======if=======
(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(pre-value fail2)
(if (true? pre-value)
(cproc env succeed fail2)
(aproc env succeed fail2)))
fail))))
(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 pred consequent alternative)
(list 'if pred consequent alternative))
;;==========analyze-if-fail=========
(define (analyze-if-fail exp)
(let ((cproc (analyze (if-fail-consequent exp)))
(aproc (analyze (if-fail-alternative exp))))
(lambda (env succeed fail)
(cproc env
succeed
(lambda ()
(aproc env succeed fail))))))
(define (if-fail-consequent exp) (cadr exp))
(define (if-fail-alternative exp) (caddr exp))
;;===========cond analyze==========
(define (analyze-cond exp)
(analyze (expand-clauses (cond-clauses exp))))
(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 (expand-clauses clauses)
(if (null? clauses)
'false ;引用的false 而不是#f
(let ((first (car clauses)) (rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "Else clause isn't last---COND-IF" clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-seq? seq) (first-seq seq))
(else (make-begin seq))))
(define (first-seq seq) (car seq))
(define (last-seq? seq) (null? (cdr seq)))
;;=======begin analyze========
(define (analyze-begin exp)
(analyze-sequence (begin-seqs exp)))
(define (begin-seqs exp) (cdr exp))
(define (make-begin seq) (cons 'begin seq))
;=====analyze-define=====
(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 (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp))) ;两种形式的define
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
;=====analyze-assignment========
(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 (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
;;========analyze-permanent-assignment========
(define (analyze-permanent-assignment exp)
(let ((var (assignment-variable exp))
(vproc (analyze (assignment-value exp))))
(lambda (env succeed fail)
(vproc env
(lambda (val fail2)
(set-variable-value! var val env)
(succeed 'ok
fail2))
fail))))
;abstract-scan
(define (lookup-frame var vars values) ;找到了返回相应值, 否则返回next
(cond ((null? vars) 'next)
((eq? var (car vars)) (car values))
(else (lookup-frame var (cdr vars) (cdr values)))))
(define (set-frame-binding! var val vars values) ;找到了改变其值，并返回新值，否则返回next
(cond ((null? vars) 'next)
((eq? var (car vars)) (begin (set-car! values val)
val))
(else (set-frame-binding! var val (cdr vars) (cdr values)))))
(define (lookup-variable-value var env)
(define (env-loop env)
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(let ((result (lookup-frame var (frame-variables frame) (frame-values frame))))
(if (eq? result '*unassigned*)
(error "Unbound variable" var)
(if (not (eq? result 'next))
result
(env-loop (enclosing-environment env))))))))
(env-loop env))
(define (set-variable-value! var val env)
(define (env-loop env)
(if (eq? env the-empty-environment)
(error "Unbound variable--SET!" var)
(let ((frame (first-frame env)))
(let ((result (set-frame-binding! var val
(frame-variables frame) (frame-values frame))))
(if (not (eq? result 'next))
result
(env-loop (enclosing-environment env)))))))
(env-loop env))
(define (define-variable! var val env)
(let ((frame (first-frame env)))
(let ((result (set-frame-binding! var val
(frame-variables frame) (frame-values frame))))
(if (not (eq? result 'next))
result
(add-binding-to-frame! var val frame)))))
;;=====analyze-application=====
(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
;;success continuation for this aproc
(lambda (arg fail2)
(get-args (cdr aprocs)
env
;;success continuation for recursive
(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))))
;;====procedure-related-to-analyze-application======
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
;;====for-the-amb-apply=====
(define-syntax quote-x
(syntax-rules ()
((_ exp)
(list 'quote exp))))
(define (quote-a-list items)
(if (null? items)
'()
(cons (quote-x (car items))
(quote-a-list (cdr items)))))
;;======the-scheme-apply-in-amb-eval=========
(define (analyze-apply exp)
(let ((arg (analyze (caddr exp))))
(lambda (env succeed fail)
((analyze (cons (cadr exp)
(quote-a-list (arg env (lambda(val f) val) fail))))
env succeed fail))))
;-------------extend-environment
(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))))
;;--------analyze-amb--------
(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))))
(define (amb-choices exp) (cdr exp))
;;----------analyze-ramb----------
(define (analyze-ramb exp)
(let ((cprocs (map analyze (amb-choices exp))))
(lambda (env succeed fail)
(define (try-next choices)
(if (null? choices)
(fail)
(let ((random-pick (random-choose choices)))
(let ((the-right-one (car random-pick))
(rest-ones (cdr random-pick)))
(the-right-one env
succeed
(lambda() (try-next rest-ones)))))))
(try-next cprocs))))
(define (random-choose seq)
(define (random-integer-between low high)
(+ low (random (+ (- high low) 1))))
(let ((ref (random-integer-between 1 (length seq))))
(define (foo k items)
(cond ((null? items) (cons '() ()))
((= k 1) items)
(else (let ((foo-next (foo (- k 1) (cdr items))))
(cons (car foo-next)
(cons (car items) (cdr foo-next)))))))
(foo ref seq)))
;-------------install----------------
(define (install-analyze-package)
(put 'analyze 'quote analyze-quoted)
(put 'analyze 'lambda analyze-lambda)
(put 'analyze 'if analyze-if)
(put 'analyze 'set! analyze-assignment)
(put 'analyze 'define analyze-definition)
(put 'analyze 'amb analyze-amb)
(put 'analyze 'let analyze-let)
(put 'analyze 'begin analyze-begin)
(put 'analyze 'cond analyze-cond)
(put 'analyze 'and analyze-and)
(put 'analyze 'or analyze-or)
(put 'analyze 'permanent-set! analyze-permanent-assignment)
(put 'analyze 'ramb analyze-ramb)
(put 'analyze 'if-fail analyze-if-fail)
(put 'analyze 'apply analyze-apply)
; (put 'analyze 'let analyze-let)
'done)
;--------let analyze (let <bindings> <body>)-------------
(define (analyze-let exp)
(let ((vars (map car (let-bindings exp)))
(vals (map cadr (let-bindings exp)))
(body (let-body exp)))
(analyze (cons (make-lambda vars body) vals))))
(define (let-bindings x) (cadr x))
(define (let-body x) (cddr x))
;--run-in-scheme
(define (application? exp) (pair? exp))
(define the-empty-environment '())
(define (get-tag x) (car x))
(define (tagged-list? proc tag)
(if (pair? proc)
(eq? (car proc) tag)
false))
(define (primitive-procedure? proc) (tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cadr cadr)
(list 'cons cons)
(list 'null? null?)
(list '+ +)
(list '- -)
(list '* *)
(list '/ /)
(list '= =)
(list '< <)
(list '> >)
(list 'display display)
(list 'newline newline)
(list 'eq? eq?)
(list 'true true)
(list 'false false)
(list 'map map)
(list 'not not)
(list 'list list)
(list 'remainder remainder)
(list 'integer? integer?)
(list 'sqrt sqrt)
(list 'abs abs)
(list 'equal? equal?)
(list 'current-inexact-milliseconds current-inexact-milliseconds)
(list 'length length)
(list 'append append)
(list 'memq memq)
(list 'random random)
(list 'even? even?)
;...
))
(define (primitive-procedure-names) (map car primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda(proc) (list 'primitive (cadr proc)))
primitive-procedures))
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme (primitive-implementation proc) args))
(define (apply-in-underlying-scheme proc args)
(apply proc args))
(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))
;;---------driver-loop-----------
(define input-prompt ";;;Amb-Eval input: ")
(define output-prompt ";;;Amb-Eval value: ")
(define (install-custom-primitive)
(let ((succ (lambda (val f) val))
(fail (lambda () ())))
(ambeval '(define (require p) (if (not p) (amb)))
the-global-environment
succ
fail)
(ambeval '(define (an-element-of items)
(require (not (null? items)))
(amb (car items) (an-element-of (cdr items))))
the-global-environment
succ
fail)
(ambeval '(define (distinct? items)
(define (member? x seq)
(cond ((null? seq) false)
((equal? x (car seq)) true)
(else (member? x (cdr seq)))))
(cond ((null? items) true)
((null? (cdr items)) true)
((member? (car items) (cdr items)) false)
(else (distinct? (cdr items)))))
the-global-environment
succ
fail)
(ambeval '(define (map proc items)
(if (null? items)
'()
(cons (proc (car items))
(map proc (cdr items)))))
the-global-environment
succ
fail)
(ambeval '(define (an-integer-between low high)
(if (> low high)
(amb)
(amb low (an-integer-between (+ 1 low)
high))))
the-global-environment
succ
fail)
'install-custom-primitive-done))
(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
;;succeed
(lambda(val next-alternative)
(announce-output output-prompt)
(user-print val)
(internal-loop next-alternative))
;;fail
(lambda()
(announce-output ";;;There are no more value 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)
'<procedure-env>))
(display object)))
;test
(install-analyze-package)
(install-custom-primitive)
- Login to post comments
- 136 reads
|
src="http://pagead2.googlesyndication.com/pagead/show_ads.js"> |
简体中文
English