diff options
Diffstat (limited to 'ps06_rule_systems')
| -rw-r--r-- | ps06_rule_systems/load.scm | 2 | ||||
| -rw-r--r-- | ps06_rule_systems/problem5.scm | 147 |
2 files changed, 148 insertions, 1 deletions
diff --git a/ps06_rule_systems/load.scm b/ps06_rule_systems/load.scm index 62117c7..4079b3d 100644 --- a/ps06_rule_systems/load.scm +++ b/ps06_rule_systems/load.scm @@ -5,4 +5,4 @@ (define (rule-memoize x) x) ;;; NB: Scaffolding stub for prob 4.5 -(load "rules")
\ No newline at end of file +(load "rules") diff --git a/ps06_rule_systems/problem5.scm b/ps06_rule_systems/problem5.scm new file mode 100644 index 0000000..d10bf65 --- /dev/null +++ b/ps06_rule_systems/problem5.scm @@ -0,0 +1,147 @@ + +;(load "load") + +;;; Problem 6.5 + +; note: I commented out the rule-memoize line from "load.scm" so I can define +; that procedure here then reload the algebra stuff + +(define *memoize-table* '()) + +; this will make a lazy table with n elements +(define (make-table n) + (define (recurse n) + (cond ((zero? n) '()) + (else (cons '() (recurse (- n 1)))))) + (cons '*finite-table* (recurse n))) + +(define (bring-to-front! x y table) + (set-cdr! table + (cons (list x y) + (list-transform-negative + (cdr table) + (lambda (element) + (and (not (null? element)) + (equal? x (car element)))))))) + +(define (insert! x y table) + (set-cdr! table + (cons (list x y) + (except-last-pair (cdr table))))) + +(define (lookup x table) + (define (recurse list) + (cond ((null? list) '()) + ((null? (car list)) '()) + ((equal? x (car (car list))) + (let ((res (car (cdr (car list))))) + (bring-to-front! x res table) + res)) + (else (recurse (cdr list))))) + (recurse (cdr table))) + +#| Test +(define tt (make-table 6)) +(insert! 'asdf 3 tt) +(insert! '(+ 1 2) #f tt) +tt +;Value 21: (*finite-table ((+ 1 2) #f) (asdf 3) ()) +(lookup 'asdf tt) +; 3 +tt +;Value 27: (*finite-table (asdf 3) ((+ 1 2) #f) () () () ()) +(lookup 'wacky tt) +; '() +(lookup '(+ 1 2) tt) +; #f + +|# + +(set! *memoize-table* (make-table 25)) + +(define (rule-memoize f) + (lambda (expr) + (let ((table *memoize-table*)) + (let ((last-result (lookup expr table))) + (cond + ((null? last-result) + (let ((this-result (f expr))) + (insert! expr this-result table) + this-result)) + (else last-result)))))) + +#| TEST IT OUT! + +(pp (algebra-2 '(+ x x x))) +; (+ x x x) + +(algebra-2 '(+ 4 5 (* 3 4) x)) +; (+ 21 x) + +(algebra-2 '(* 34 8 (+ 4 5 (* 3 4) x) x)) + +|# + +; but as noted in SICP this isn't really what we want, we need to +; override rule-simplifier so simplify-expression calls +; (rule-memoize simplified-expression). Otherwise we're only memoizing +; the application of entire expressions, not recursively through the +; subexpressions which is where this gets useful. + +(define (rule-simplifier the-rules) + (define memo-simplify-expression + (rule-memoize + (lambda (expression) + (let ((ssubs + (if (list? expression) + (map memo-simplify-expression expression) + expression))) + (let ((result (try-rules ssubs the-rules))) + (if result + (memo-simplify-expression result) + ssubs)))))) + memo-simplify-expression) + +(load "rules") + +#| TEST IT OUT! + +(pp (algebra-2 '(+ x x x))) +; (+ x x x) + +(algebra-2 '(+ 4 5 (* 3 4) x)) +; (+ 21 x) + +(algebra-2 '(* 34 8 (+ 4 5 (* 3 4) x) x)) +;Value 13: (* 272 x (+ 21 x)) + +*memoize-table* +;Value 12: (*finite-table* +((* 34 8 (+ 4 5 (* 3 4) x) x) (* 272 x (+ 21 x))) +((+ 4 5 (* 3 4) x) (+ 21 x)) +((+ x x x) (+ x x x)) +((* 8 34 (+ 21 x) x) (* 272 x (+ 21 x))) +((* 8 34 x (+ 21 x)) (* 272 x (+ 21 x))) +((* 272 x (+ 21 x)) (* 272 x (+ 21 x))) +((+ 21 x) (+ 21 x)) +(x x) +(272 272) +(* *) +(34 34) +(8 8) +(+ +) +((+ 9 12 x) (+ 21 x)) +(21 21) +(12 12) +(9 9) +((* 3 4) 12) +((* 12) 12) +(4 4) +(3 3) +(5 5) +() () ()) + +; hmmmm, maybe don't want to memoize /every/ little thing? +|# + + |