summaryrefslogtreecommitdiffstats
path: root/ps06_rule_systems/problem5.scm
diff options
context:
space:
mode:
Diffstat (limited to 'ps06_rule_systems/problem5.scm')
-rw-r--r--ps06_rule_systems/problem5.scm147
1 files changed, 147 insertions, 0 deletions
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?
+|#
+
+