;;; ;;; lazeval.ss ;;; meval.ss adapted for Lazy Evaluation ;;; (require-library "trace.ss") (load "listprocs.ss") (define the-empty-environment '()) (define (make-new-environment frame env) (cons frame env)) (define (first-frame env) (car env)) (define (enclosing-environment env) (cdr env)) (define (make-empty-frame) (list)) (define (extend-environment names values env) (make-new-environment (map (lambda (name value) (cons name value)) names values) env)) (define (environment-get-value! name env) (if (null? env) (error "No binding for" name) (if (frame-contains? name (first-frame env)) (let ((np (frame-lookup-name name (first-frame env)))) (if (thunk? (cdr np)) (set-cdr! np (lazeval (thunk-expr (cdr np)) (thunk-env (cdr np))))) (cdr np)) (environment-get-value! name (enclosing-environment env))))) (define (bind-variable name value env) (add-binding-to-frame! name value (first-frame env))) (define (add-binding-to-frame! name value frame) (car frame) ;; ! frame cannot be null or append! doesn't work (append! frame (list (cons name value)))) ; Note why we use append! not append (define (frame-contains? name frame) (insertlg (lambda (var result) (if (eq? (car var) name) #t result)) frame #f)) (define (frame-lookup-name name frame) (if (null? frame) (error "Name not found in frame:" name) (if (eq? (car (car frame)) name) (car frame) (frame-lookup-name name (cdr frame))))) (define (tagged-list? expr tag) (if (pair? expr) (eq? (car expr) tag) #f)) (define (primitive-procedure? expr) (tagged-list? expr 'primitive-procedure)) (define (make-primitive-procedure expr) (list 'primitive-procedure expr)) (define (primitive-procedure-procedure procedure) (cadr procedure)) (define (self-evaluating? expr) (or (number? expr) (string? expr) (primitive-procedure? expr))) (define (variable? expr) (symbol? expr)) (define (lambda? expr) (tagged-list? expr 'lambda)) (define (make-lambda params body) (list 'lambda params body)) (define (lambda-parameters expr) (cadr expr)) (define (lambda-body expr) (cddr expr)) (define (make-procedure parameters body environment) (list 'procedure parameters body environment)) (define (compound-procedure? expr) (tagged-list? expr 'procedure)) (define (procedure-parameters procedure) (cadr procedure)) (define (procedure-body procedure) (caddr procedure)) (define (procedure-environment procedure) (cadddr procedure)) (define (application? expr) (pair? expr)) (define (application-operator expr) (car expr)) (define (application-operands expr) (cdr expr)) (define (thunk? expr) (tagged-list? expr 'thunk)) (define (make-thunk expr env) (list 'thunk expr env)) (define (thunk-expr thunk) (cadr thunk)) (define (thunk-env thunk) (caddr thunk)) ;;; ;;; Core of the evaluator - eval and apply ;;; ;;; We have named them "lazeval" and "lazapply" to avoid any confusion with ;;; the built-in Scheme eval and apply. ;;; (define (lazapply-primitive procedure operands) ;;; The underlying Scheme apply (apply (primitive-procedure-procedure procedure) operands)) (define (lazapply procedure operands env) (cond ((primitive-procedure? procedure) (lazapply-primitive procedure (map (lambda (op) (lazeval op env)) operands))) ((compound-procedure? procedure) (lazeval-sequence (procedure-body procedure) (extend-environment (procedure-parameters procedure) (map (lambda (op) (make-thunk op env)) operands) (procedure-environment procedure)))) (else (error "Unknown applicator: " procedure)))) (define (lazeval-sequence seq env) (if (= (length seq) 1) (lazeval (car seq) env) (begin (lazeval (car seq) env) (lazeval-sequence (cdr seq) env)))) (define (definition? expr) (tagged-list? expr 'define)) (define (definition-variable expr) (cadr expr)) (define (definition-value expr) (caddr expr)) (define (define-variable! var value env) ;;; We always add the new definition at the beginning of the frame. That way, ;;; frame-lookup-name will find the new definition first if it is redefined. (set-car! env (cons (cons var value) (car env))) 'ok) (define (lazeval expr env) (cond ((self-evaluating? expr) expr) ((variable? expr) (environment-get-value! expr env)) ((lambda? expr) (make-procedure (lambda-parameters expr) (lambda-body expr) env)) ((definition? expr) (define-variable! (definition-variable expr) (lazeval (definition-value expr) env) env)) ((application? expr) (lazapply (lazeval (application-operator expr) env) (application-operands expr) env)) (else (error "Unknown expression: " exp)))) ;;; Mini-scheme can add, multiply and subtract using the underlying Scheme primitives: (define the-global-environment (make-new-environment (list (cons '+ (make-primitive-procedure +)) (cons '* (make-primitive-procedure *)) (cons '- (make-primitive-procedure -)) ) the-empty-environment)) ;;; Mini-scheme is driven by the following driver loop: (define input-prompt ";;; Mini-Scheme input:") (define output-prompt ";;; Mini-Scheme value:") (define (driver-loop) (prompt-for-input input-prompt) (let ((input (read))) (if (eq? input 'quit) (display "Done.") (let ((output (lazeval input the-global-environment))) (announce-output output-prompt) (user-print output) (driver-loop))))) (define (prompt-for-input string) (newline) (newline) (display string) (newline)) (define (announce-output string) (display string) (newline)) (define (user-print object) (if (compound-procedure? object) (display (list 'compound-procedure (procedure-parameters object) (procedure-body object) ')) (display object))) ;;; ;;; Factoring Code ;;; ;;; powerset code from the Knapsack problem (22 Feburary Notes) (define (powerset s) (if (null? s) (list s) (let ((psc (powerset (cdr s)))) (append psc (map (lambda (el) (cons (car s) el)) psc))))) ;;; the first 200 prime numbers (define prime-list (list 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 557 563 569 571 577 587 593 599 601 607 613 617 619 631 641 643 647 653 659 661 673 677 683 691 701 709 719 727 733 739 743 751 757 761 769 773 787 797 809 811 821 823 827 829 839 853 857 859 863 877 881 883 887 907 911 919 929 937 941 947 953 967 971 977 983 991 997 1009 1013 1019 1021 1031 1033 1039 1049 1051 1061 1063 1069 1087 1091 1093 1097 1103 1109 1117 1123 1129 1151 1153 1163 1171 1181 1187 1193 1201 1213 1217 1223)) ;;; Dumb, non-quantum factoring procedure (define (productlist lst) (insertlg * lst 1)) (define (make-copies p n) (define (make-copies-worker p n plist) (if (> (* p (productlist plist)) n) plist (make-copies-worker p n (cons p plist)))) (make-copies-worker p n '())) (define (duplicate-elements primes n) (if (null? primes) null (append (make-copies (car primes) n) (duplicate-elements (cdr primes) n)))) (define (factor n) (let ((primes (filter (lambda (p) (<= p (/ n 2))) prime-list))) (let ((expand-primes (duplicate-elements primes n))) (let ((possible-factorizations (powerset expand-primes))) (let ((factors (filter (lambda (flist) (= (productlist flist) n)) possible-factorizations))) (if (null? factors) 'prime (car factors)))))))