blob: d10bf658d69f3ede3f66e56bfd64cdaccba6c39a (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
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?
|#
|
