diff options
Diffstat (limited to 'ps03_evalapply/bnewbold_work.scm')
| -rw-r--r-- | ps03_evalapply/bnewbold_work.scm | 367 |
1 files changed, 367 insertions, 0 deletions
diff --git a/ps03_evalapply/bnewbold_work.scm b/ps03_evalapply/bnewbold_work.scm new file mode 100644 index 0000000..e74c65e --- /dev/null +++ b/ps03_evalapply/bnewbold_work.scm @@ -0,0 +1,367 @@ +;;; 6.945 Problem Set #3 Scheme Code +;;; 02/25/2009 +;;; Bryan Newbold + +; Note: See the attached bnewbold_ps3.txt for comments + +; This file should be loaded into the generic-evaluation-environment + +;;; Problem 3.1 + +(defhandler apply + (lambda (proc-vector ops env) + (vector-map + (lambda (proc) + (apply proc ops env)) + proc-vector)) + (lambda (thing) + (and (vector? thing) + (not (compound-procedure? thing))))) + +(define add1 (lambda (x) (+ 1 x))) + +#| Test +eval> (define cube (lambda (x) (* x x x))) +cube + +eval> (cube 3) +27 + +eval> ((vector cube sin cos sqrt) 1) +#(1 .8414709848078965 .5403023058681398 1) +|# + +;;; Problem 3.2 + +(define ALLOW-SELF-EVALUATING-SYMBOLS #t) + +(define (unbound-symbol? s) + (if (symbol? s) + (eq? 'unbound (environment-reference-type + (nearest-repl/environment) + s)) + #f)) + +(define ((binary-pass symbol) a b) + (if (not ALLOW-SELF-EVALUATING-SYMBOLS) + (error "We don't ALLOW-SELF-EVALUATING-SYMBOLS!") + (if (for-all? + (list a b) + (lambda (x) + (or (number? x) + (unbound-symbol? x) + (and (list? x) + (not (null? x)) + (or (member (car x) (list '+ '* '/ '-)) + (literal-function? (car x))))))) ; see below + (list symbol a b) + (error "Not a number or symbol: " a b)))) + + +(define add (make-generic-operator 2 (binary-pass '+))) +(define multiply (make-generic-operator 2 (binary-pass '*))) +(define divide (make-generic-operator 2 (binary-pass '/))) +(define subtract (make-generic-operator 2 (binary-pass '-))) + +(defhandler add + number? number?) +(defhandler multiply * number? number?) +(defhandler divide / number? number?) +(defhandler subtract - number? number?) + + + +#| Test: +(add (multiply 42 5365) (add (subtract 'a 3) (divide 4 5))) +;Value: (+ 225330 (+ (- a 3) 4/5)) +(add (multiply 42 5365) (add (subtract 'a cos) (divide 4 5))) +;Not a number or symbol: a #[compiled-procedure 69 ("arith" #xce) #xf #x1c05fb] +|# + +(define *literal-functions* '()) + +(define (declare-literal-function f) + (if (and (symbol? f) (< (string-length (symbol->string f)) 2)) + (begin + (set! *literal-functions* (cons (environment-define + (nearest-repl/environment) + f + f) + *literal-functions*)) + (display + "Okey-doke, it is now a literal function")) + (error "Not a good function name (make it short): " f))) + +(define (literal-function? f) + (if (member f *literal-functions*) + #t + #f)) + +(defhandler apply (lambda (f opts env) + (if ALLOW-SELF-EVALUATING-SYMBOLS + (cons f (evaluate-list opts env)) + (error "We don't ALLOW-SELF-EVALUATING-SYMBOLS: " f))) + literal-function?) + +(defhandler eval (lambda (e env) e) + literal-function?) + +#| Test: TODO COPY +#| +eval> (declare-literal-function 'a) +Okey-doke, it is now a literal function#!unspecific + +eval> a +a + +eval> (a 2 4 5) +(a 2 4 5) + +eval> (add (a 1 2) 'b) +(+ (a 1 2) b) + +eval> (multiply (a (add 3 4) 'b) 99) +(* (a 7 b) 99) +|# +|# + +;;; Problem 3.3 + +(define add-streams + (lambda (a b) + (kons (+ (car a) (car b)) + (add-streams (cdr a) (cdr b))))) + +(define ref-stream + (lambda (s n) + (if (= n 0) + (car s) + (ref-stream (cdr s) (- n 1))))) + +(define (map-stream proc items) + (kons (proc (car items)) + (map-stream proc (cdr items)))) + +(define (scale-stream items factor) + (map-stream (lambda (x) (* x factor)) + items)) + +#| type these in manually to the eval> prompt + +(define (integral (integrand lazy) initial-value dt) + (define int + (kons initial-value + (add-streams (scale-stream integrand dt) + int))) + int) +; integral +(define (solve f y0 dt) + (define y (integral dy y0 dt)) + (define dy (map-stream f y)) + y) +; solve +(ref-stream (solve (lambda (x) x) 1 0.001) 1000) +; 2.716923932235896 + +|# + +;;; Problem 3.4a + +(define some-options (list 'beef + 'thai 'indian 'pasta 'sandwich + 'crepes 'mexican)) ; len=7 + +#| +(define whats-for-dinner + (kons (list-ref some-options (random-integer 7)) + whats-for-dinner)) + + +(define (mealplan w) + (pp (car w)) + (mealplan (cdr w))) + +; Test: + +eval> (mealplan whats-for-dinner) +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +sandwich +...etc + +;That's depressing! + +|# + + +;;; Problem 3.5 + +; Profiling! + +(define PROFILING-ENABLED #f) + +(define *primative-call-database* + (make-eq-hash-table)) + +(define *compound-call-database* + (make-eq-hash-table)) + +#| +(define (clear-profile-results) + (set! PROFILING-ENABLED #f) + ( *primative-call-database* + (set! *compound-call-database* + (make-eq-hash-table)) + (set! PROFILING-ENABLED #t)) +(define cpr clear-profile-results) ; shorter +|# + + +(define (print-profile-results) + (set! PROFILING-ENABLED #f) + (begin + (display "----------- Profiling Results ---------------") (newline) + (display "Primative Procedures:") (newline) + (hash-table/for-each *primative-call-database* + (lambda (key val) + (display " ") + (display val) + (display " ") + (display key) (newline))) + (display "Compound Procedures:") (newline) + (hash-table/for-each *compound-call-database* + (lambda (key val) + (display " ") + (display val) + (display " ") + (display key) (newline))) + (display "----------- End of Table ---------------") (newline) + (set! PROFILING-ENABLED #t))) + +(define ppr print-profile-results) ; shorter + + +(define (count-primative proc) + (hash-table-set! *primative-call-database* + proc + (+ 1 (hash-table-ref/default *primative-call-database* + proc + 0)))) + +(define (count-compound proc) + (hash-table-set! *compound-call-database* + proc + (+ 1 (hash-table-ref/default *compound-call-database* + proc + 0)))) + +; from rtdata: +(define strict-primative-procedure? procedure?) + +(defhandler apply + (lambda (proc opers env) + (if PROFILING-ENABLED (count-primative proc)) + (apply-primitive-procedure proc + (evaluate-list opers env))) + strict-primative-procedure?) + +(defhandler apply + (lambda (procedure operands calling-environment) + (if PROFILING-ENABLED (count-compound procedure)) + (if (not (= (length (procedure-parameters procedure)) + (length operands))) + (error "Wrong number of operands supplied")) + (let ((arguments + (map (lambda (parameter operand) + (evaluate-procedure-operand parameter + operand + calling-environment)) + (procedure-parameters procedure) + operands))) + (eval (procedure-body procedure) + (extend-environment + (map procedure-parameter-name + (procedure-parameters procedure)) + arguments + (procedure-environment procedure))))) + compound-procedure?) + +#| Testing + +;; the order is a little off here, I cherry picked out examples from a +;; session so the actual counts are off a bit + +(init) +eval> (ppr) +----------- Profiling Results --------------- +Primative Procedures: +Compound Procedures: +----------- End of Table --------------- + +eval> (define cube (lambda (x) (* x x x))) +cube + +eval> (cube 12) +1728 + +eval> (ppr) +----------- Profiling Results --------------- +Primative Procedures: + 2 #[compound-procedure 18 print-profile-results] + 1 #[arity-dispatched-procedure 20] + 1 #[arity-dispatched-procedure 19] +Compound Procedures: + 1 #(compound-procedure (x) (* x x x) #((cube) (#(compound-procedure (x) (* + x x x) #((cube) (#(compound-procedure (x) (* x x x) #((cube) (#(compound-proced +ure ... ... ...)) ()))) ()))) ())) +----------- End of Table --------------- + +eval> (define (fib n) (if (< n 2) 1 (+ (fib (- n 2)) (fib (- n 1)))))) +fib + +eval> (fib 12) +233 + +eval> (ppr) +----------- Profiling Results --------------- +Primative Procedures: + 1 #[compound-procedure 21 operator] + 13134 #[arity-dispatched-procedure 19] + 1 #[compound-procedure 22 operator] + 1 #[arity-dispatched-procedure 20] + 26168 #[arity-dispatched-procedure 23] + 5 #[compound-procedure 18 print-profile-results] + 26173 #[arity-dispatched-procedure 24] +Compound Procedures: + 1 #(compound-procedure (x) (* x x x) #((fib cube) (#(compound-procedure (n) (if (< n 2) 1 (+ (fib (- n 2)) (fib (- n 1)))) #((fib cube) (#(compound-procedure (n) (if (< n 2) 1 (+ (fib ...) (fib ...))) #((fib cube) (#(compound-procedure ... ... ...) #(compound-procedure ... ... ...)) ())) #(compound-procedure (x) (* x x x) #((fib cube) (#(compound-procedure ... ... ...) #(compound-procedure ... ... ...)) ()))) ())) #(compound-procedure (x) (* x x x) #((fib cube) (#(compound-procedure (n) (if (< n 2) 1 (+ (fib ...) (fib ...))) #((fib cube) (#(compound-procedure ... ... ...) #(compound-procedure ... ... ...)) ())) #(compound-procedure (x) (* x x x) #((fib cube) (#(compound-procedure ... ... ...) #(compound-procedure ... ... ...)) ()))) ()))) ())) + 26172 #(compound-procedure (n) (if (< n 2) 1 (+ (fib (- n 2)) (fib (- n 1)))) #((fib cube) (#(compound-procedure (n) (if (< n 2) 1 (+ (fib (- n 2)) (fib (- n 1)))) #((fib cube) (#(compound-procedure (n) (if (< n 2) 1 (+ (fib ...) (fib ...))) #((fib cube) (#(compound-procedure ... ... ...) #(compound-procedure ... ... ...)) ())) #(compound-procedure (x) (* x x x) #((fib cube) (#(compound-procedure ... ... ...) #(compound-procedure ... ... ...)) ()))) ())) #(compound-procedure (x) (* x x x) #((fib cube) (#(compound-procedure (n) (if (< n 2) 1 (+ (fib ...) (fib ...))) #((fib cube) (#(compound-procedure ... ... ...) #(compound-procedure ... ... ...)) ())) #(compound-procedure (x) (* x x x) #((fib cube) (#(compound-procedure ... ... ...) #(compound-procedure ... ... ...)) ()))) ()))) ())) +----------- End of Table --------------- + +|# + |