merged

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?
+|#
+
+