blob: 360800a81a56721414be5333e6ec48c0839c41cb (
plain) (
tree)
|
|
;;;;Nondeterministic evaluator
;;;;Different from the one in chapter 4 of SICP, in that it's based on the
;;;; vanilla metacircular evaluator, rather than on the analyzing one.
;;;;This file can be loaded into Scheme as a whole.
;;;;Then you can initialize and start the evaluator by evaluating
;;;; the expression (mce).
;;;from section 4.1.4 -- must precede def of metacircular apply
(define apply-in-underlying-scheme apply)
;;;SECTION 4.1.1
(define (ambeval exp env succeed fail)
(cond ((self-evaluating? exp) (succeed exp fail))
((variable? exp)
(succeed (lookup-variable-value exp env)
fail))
((quoted? exp) (succeed (text-of-quotation exp) fail))
((assignment? exp) (eval-assignment exp env succeed fail))
((definition? exp) (eval-definition exp env succeed fail))
((if? exp) (eval-if exp env succeed fail))
((lambda? exp)
(succeed (make-procedure (lambda-parameters exp)
(lambda-body exp)
env)
fail))
((begin? exp)
(eval-sequence (begin-actions exp) env succeed fail))
((cond? exp) (ambeval (cond->if exp) env succeed fail))
((let? exp) (ambeval (let->combination exp) env succeed fail)) ;**
((amb? exp) (eval-amb exp env succeed fail)) ;**
((application? exp)
(eval-application exp env succeed fail))
(else
(error "Unknown expression type -- EVAL" exp))))
(define (eval-application exp env succeed fail)
(ambeval (operator exp)
env
(lambda (proc fail2)
(get-args (operands exp)
env
(lambda (args fail3)
(execute-application proc args succeed fail3))
fail2))
fail))
(define (get-args exps env succeed fail)
(if (null? exps)
(succeed '() fail)
(ambeval (car exps)
env
(lambda (arg fail2)
(get-args (cdr exps)
env
(lambda (args fail3)
(succeed (cons arg args)
fail3))
fail2))
fail)))
(define (execute-application procedure arguments succeed fail)
(cond ((primitive-procedure? procedure)
(succeed (apply-primitive-procedure procedure arguments) fail))
((compound-procedure? procedure)
(eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure))
succeed
fail))
(else
(error
"Unknown procedure type -- APPLY" procedure))))
(define (eval-if exp env succeed fail)
(ambeval (if-predicate exp)
env
(lambda (pred-value fail2)
(if (true? pred-value)
(ambeval (if-consequent exp)
env
succeed
fail2)
(ambeval (if-alternative exp)
env
succeed
fail2)))
fail))
(define (eval-sequence exps env succeed fail)
(define (loop first-exp rest-exps succeed fail)
(if (null? rest-exps)
(ambeval first-exp env succeed fail)
(ambeval first-exp
env
(lambda (first-value fail2)
(loop (car rest-exps) (cdr rest-exps) succeed fail2))
fail)))
(if (null? exps)
(error "Empty sequence")
(loop (car exps) (cdr exps) succeed fail)))
(define (eval-definition exp env succeed fail)
(ambeval (definition-value exp)
env
(lambda (val fail2)
(define-variable! (definition-variable exp) val env)
(succeed 'ok fail2))
fail))
(define (eval-assignment exp env succeed fail)
(ambeval (assignment-value exp)
env
(lambda (val fail2)
(let* ((var (assignment-variable exp))
(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 (eval-amb exp env succeed fail)
(define (try-next choices)
(if (null? choices)
(fail)
(ambeval (car choices)
env
succeed
(lambda ()
(try-next (cdr choices))))))
(try-next (amb-choices exp)))
;;;SECTION 4.1.2
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
((boolean? exp) true)
(else false)))
(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 (variable? exp) (symbol? exp))
(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? 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))
(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 ; no else clause
(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 (amb? exp) (tagged-list? exp 'amb))
(define (amb-choices exp) (cdr exp))
;;;SECTION 4.1.3
(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))))
;;;SECTION 4.1.4
(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))
;[do later] (define the-global-environment (setup-environment))
(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 'cons cons)
(list 'null? null?)
(list '+ +)
(list '- -)
(list '* *)
(list '/ /)
(list '= =)
(list 'list list)
(list 'append append)
(list 'equal? equal?)
;; more primitives
))
(define (primitive-procedure-names)
(map car
primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
;[moved to start of file] (define apply-in-underlying-scheme apply)
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(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
;; ambeval success
(lambda (val next-alternative)
(announce-output output-prompt)
(user-print val)
(internal-loop next-alternative))
;; ambeval failure
(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)
'<procedure-env>))
(display object)))
;;; Support for Let (as noted in footnote 56, p.428)
(define (let? exp) (tagged-list? exp 'let))
(define (let-bindings exp) (cadr exp))
(define (let-body exp) (cddr exp))
(define (let-var binding) (car binding))
(define (let-val binding) (cadr binding))
(define (make-combination operator operands) (cons operator operands))
(define (let->combination exp)
;;make-combination defined in earlier exercise
(let ((bindings (let-bindings exp)))
(make-combination (make-lambda (map let-var bindings)
(let-body exp))
(map let-val bindings))))
;; A longer list of primitives -- suitable for running everything in 4.3
;; Overrides the list in ch4-mceval.scm
;; Has Not to support Require; various stuff for code in text (including
;; support for Prime?); integer? and sqrt for exercise code;
;; eq? for ex. solution
(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'null? null?)
(list 'list list)
(list 'append append)
(list 'memq memq)
(list 'member member)
(list 'not not)
(list '+ +)
(list '- -)
(list '* *)
(list '= =)
(list '> >)
(list '>= >=)
(list 'abs abs)
(list 'remainder remainder)
(list 'integer? integer?)
(list 'sqrt sqrt)
(list 'eq? eq?)
(list 'equal? equal?)
(list 'pair? pair?)
;; more primitives
))
;;;Following are commented out so as not to be evaluated when
;;; the file is loaded.
;;(define the-global-environment (setup-environment))
;;(driver-loop)
;; Added at Berkeley:
(define the-global-environment '())
(define (mce)
(set! the-global-environment (setup-environment))
(ambeval '(define (require p) (if (not p) (amb)))
the-global-environment
(lambda (a b) #t)
(lambda () #t))
(driver-loop))
|