;;; 6.945 Problem Set #6 Source Code
;;; 03/11/2009
;;; Bryan Newbold <bnewbold@mit.edu>

;(load "load")

;;; Problem 6.4

(define algebra-3
  (rule-simplifier
   (list

    ;; Sums

    (rule (+ (? a)) none (? a))

    (rule (+ (?? a) (+ (?? b)))
	  none
	  (+ (?? a) (?? b)))

    (rule (+ (+ (?? a)) (?? b))
	  none
	  (+ (?? a) (?? b)))

    (rule (+ (?? a) (? y) (? x) (?? b))
	  (expr<? x y)
	  (+ (?? a) (? x) (? y) (?? b)))
    

    ;; Products

    (rule (* (? a)) none (? a))

    (rule (* (?? a) (* (?? b)))
	  none
	  (* (?? a) (?? b)))

    (rule (* (* (?? a)) (?? b))
	  none
	  (* (?? a) (?? b)))

    (rule (* (?? a) (? y) (? x) (?? b))
	  (expr<? x y)
	  (* (?? a) (? x) (? y) (?? b)))

    ;; Distributive law

    (rule (* (? a) (+ (?? b)))
	  none
	  (+ (?? (map (lambda (x) `(* ,a ,x)) b))))

    ;; Numerical simplifications below

    (rule (+ 0 (?? x)) none (+ (?? x)))

    (rule (+ (? x number?) (? y number?) (?? z))
	  none
	  (+ (? (+ x y)) (?? z)))


    (rule (* 0 (?? x)) none 0)
     
    (rule (* 1 (?? x)) none (* (?? x)))

    (rule (* (? x number?) (? y number?) (?? z))
	  none
	  (* (? (* x y)) (?? z)))

    ;; Collect terms

    (rule (+ (?? s) (? x) (? x) (?? e))
	  none
	  (+ (?? s) (* 2 (? x)) (?? e)))

    (rule (+ (?? s) (* (?? x)) (* (?? x)) (?? e))
	  none
	  (+ (?? s) (* 2 (?? x)) (?? e)))

    (rule (+ (?? s) (? x) (?? m) (* (? n number?) (? x)) (?? e))
	  none
	  (+ (?? s) (?? m) (* (? (+ 1 n)) (? x)) (?? e)))

    (rule (+ (?? s) (* (? n number?) (?? x)) (* (? p number?) (?? x)) (?? e))
	  none
	  (+ (?? s) (* (? (+ n p)) (? x)) (?? e)))

    )))

#| Test!

(algebra-3 '(+ x (* 4 x)))
;Value 15: (* 5 x)

(algebra-3 '(+ (* 8 1 f 34) (* 3 f)))
;Value 16: (* 275 x)

(algebra-3 '(+ x x))
;Value 42: (* 2 x)

(algebra-3 '(+ 4 s u s p))
;Value 39: (+ 4 p u (* 2 s))

(algebra-3 '(+ 1 2))
;Value: 3

(algebra-3 '(+ (* -2 h) (* 2 h)))
;Value: 0

(algebra-3 '(+ h (* 4 h)))
;Value 83: (* 5 h)

(algebra-3 '(+ (* w h) (* 4 h)))
;Value 84: (+ (* 4 h) (* h w))

(algebra-3 '(+ (* -1 h) (* 2 h)))
;Value 85: (h)

(algebra-3 '(+ x (* a x)))
;Value 86: (+ x (* a x))

(algebra-3 '(+ y (* x -2 w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3)))
;Value 87: (+ y (* 6 z) (* 7 (x y)))

|#

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