;; Nada Amin (namin@mit.edu)
;; 6.945 Problem Set 4
;; Due: Wed. 5 Mar. 2008

(load "../test-manager/load.scm")
(load "load.scm")

;; Problem 4.1

#|

The ordering restrictions is necessary in the rule for the commutative
law, because it ensures the rule is monotonic. Without this
restriction, the rule would still apply every time it is applied, and
the rule system will loop infinitely, constantly switching the terms
in the multiplication.

|#

#|

If the commutative laws did not force an odering, we would have to
write the numerical simplification rules using segments to account
that are not of interest. For example, the rules

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

would have to be written

(rule (+ (?? a) 0 (?? b)) none (+ (?? a) (?? b)))
(rule (+ (?? a) (? x number?) (?? b) (? y number?) (?? c))
      none
      (+ (? (+ x y)) (?? a) (?? b) (?? c)))

Numerical simplification would become very expensive, because matching
segments is expensive as it involves lots of backtracking. Every
segment could take O(n) to match, and so the second new rule could
take O(n^3) before failing to match.

|#

;; Problem 4.3

#|

I could make a more efficient sort by by-passing the rule system,
using the predicate to check if the expression is sorted, and, if not,
sorting it in the skeleton.

(rule (* (?? s))
      (and (length>1 s) (not (sorted? expr<? s)))
      (* (?? (sort s expr<?))))

where length>1 and sorted? have the obvious following definitions:
|#

(define (length>1 s)
  (and (not (null? s)) (not (null? (cdr s)))))

(define (sorted? cmp s)
  (if (not (length>1 s))
      #t
      (and (not (cmp (cadr s) (car s)))
	   (sorted? cmp (cdr s)))))

(define algebra-2bis
  (rule-simplifier
   (list

    ;; Sums

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

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

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

    (rule (+ (?? s))
      (and (length>1 s) (not (sorted? expr<? s)))
      (+ (?? (sort s expr<?))))

    ;; Products

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

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

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

    (rule (* (?? s))
	  (and (length>1 s) (not (sorted? expr<? s)))
	  (* (?? (sort s expr<?))))

    ;; 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)))

    )))

(define-each-test 
  (assert-equal (algebra-2bis '(* (+ y (+ z w)) x))
		'(+ (* w x) (* x y) (* x z)))
  (assert-equal (algebra-2bis '(+ (* 3 (+ x 1)) -3))
		'(* 3 x))
  (assert-equal 
   (algebra-2bis '(+ y (* x -2 w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3)))
   '(+ y z (* 5 z) (* w x) (* w x) (* -2 w x) (* 3 x y) (* 4 x y))))

;; Problem 4.4
(define (variable? term)
  (symbol? term))

(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)))

    ;; Additional simplification to collect like terms
    (rule (+ (?? a) (? z variable?) (? z) (?? b))
	  none
	  (+ (?? a) (? `(2 ,z)) (?? b)))

    (rule (+ (?? a) (? z variable?) (* (? n number?) (? z)) (?? b))
	  none
	  (+ (?? a) (? `(,(+ n 1) ,z)) (?? b)))

    (rule (+ (?? a) (* (? n number?) (?? zs)) (* (? m number?) (?? zs)) (?? b))
	  none
	  (+ (?? a) (* (?? `(,(+ n m) ,@zs))) (?? b)))

    (rule (+ (?? a) (* (?? zs)) (* (?? zs)) (?? b))
	  none
	  (+ (?? a) (* (?? `(2 ,@zs))) (?? b)))

    (rule (+ (?? a) (* (?? zs)) (* (? n number?) (?? zs)) (?? b))
	  none
	  (+ (?? a) (* (?? `(,(+ n 1) ,@zs))) (?? b)))
    )))

(define-each-test
  (assert-equal 
   (algebra-2 '(+ y (* x -2 w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3)))
   '(+ y z (* 5 z) (* w x) (* w x) (* -2 w x) (* 3 x y) (* 4 x y)))
  (assert-equal
   (algebra-3 '(+ y (* x -2 w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3)))
   '(+ y (6 z) (* 7 x y))))

;; Problem 4.5

#|

Memoization can help the simplifier by caching recent results. The
cache only stores the final big expressions, it would also be possible
to cache smaller subexpressions by replacing all calls to
simplify-expression by its memoized version (in rule-simplifier).

In order to implement a LRU memoizer mechanism, I first implement a
simple kind of doubly-linked list, which makes it easy to move entries
to the front. This is useful for an LRU memoizer, because when an
entry is accessed, we want to refresh it so that it remains in the
cache.

|#

(define (make-cell key val prev next)
  (list key (list val prev next)))

(define (cell-set-prev! cell prev)
  (set-car! (cdadr cell) prev))

(define (cell-set-next! cell next)
  (set-car! (cddadr cell) next))

(define (cell-key cell)
  (car cell))

(define (cell-val cell)
  (caadr cell))

(define (cell-prev cell)
  (cadadr cell))

(define (cell-next cell)
  (car (cddadr cell)))

(define (make-dll)
  (list #f #f))

(define (dll-first dll)
  (car dll))

(define (dll-last dll)
  (cadr dll))

(define (dll-set-first! dll first)
  (set-car! dll first))

(define (dll-set-last! dll last)
  (set-car! (cdr dll) last))

(define (dll-empty? dll)
  (eq? #f (dll-first dll)))

(define (dll-add-to-front! dll key val)
  (if (dll-empty? dll)
      (let ((cell (make-cell key val #f #f)))
	(dll-set-last! dll cell)
	(dll-set-first! dll cell))
      (let* ((next (dll-first dll))
	     (cell (make-cell key val #f next)))
	(cell-set-prev! next cell)
	(dll-set-first! dll cell))))

(define (dll-move-to-front! dll cell)
  (cond ((eq? #f (cell-prev cell))
	 dll)
	((eq? #f (cell-next cell))
	 (let ((new-last (cell-prev cell))
	       (old-first (dll-first dll)))
	   (cell-set-next! new-last #f)
	   (dll-set-last! dll new-last)
	   (cell-set-next! cell old-first)
	   (cell-set-prev! old-first cell)
	   (dll-set-first! dll cell)))))

(define (dll-delete-last! dll)
  (if (dll-empty? dll)
      #f
      (let* ((old-last (dll-last dll))
	     (new-last (cell-prev old-last)))
	(cell-set-next! new-last #f)
	(dll-set-last! dll new-last))))

(define (dll-search dll key)
  (define (search-cell cell)
    (cond ((eq? #f cell) 
	   #f)
	  ((equal? key (cell-key cell))
	   cell)
	  (else (search-cell (cell-next cell)))))
  (search-cell (dll-first dll)))

(in-test-group
 dll
 (define-test (dll)
   (define test-dll (make-dll))   
   (dll-add-to-front! test-dll 'foo 'foo-val)
   (dll-add-to-front! test-dll 'bar 'bar-val)
   (assert-eq (cell-val (dll-search test-dll 'foo))
		 'foo-val)
   (assert-eq (dll-search test-dll 'miao)
	      #f)
   (assert-eq (cell-val (dll-last test-dll))
	      'foo-val)
   (assert-eq (cell-val (dll-first test-dll))
	      'bar-val)
   (dll-move-to-front! test-dll (dll-last test-dll))   
   (assert-eq (cell-val (dll-last test-dll))
	      'bar-val)
   (assert-eq (cell-val (dll-first test-dll))
	      'foo-val)
   (dll-delete-last! test-dll)
   (assert-eq (dll-search test-dll 'bar)
	      #f)
   (assert-eq (cell-val (dll-first test-dll))
	      'foo-val)))

(define (make-lru-memoizer cache-max-size)
  (define (memoize-lru f)
    (let ((cache (make-dll))
	  (cache-size 0))
      (define (add-to-cache! key val)
	(if (= cache-size cache-max-size)
	    (begin
	      (dll-delete-last! cache)
	      (set! cache-size (- cache-size 1))))
	(dll-add-to-front! cache key val)
	(set! cache-size (+ cache-size 1)))
      (define (memo-f key)
	(let ((cell (dll-search cache key)))
	  (if (eq? #f cell)
	      (let ((val (f key)))
		(add-to-cache! key val)
		val)
	      (begin 
		(dll-move-to-front! cache cell)
		(cell-val cell)))))
      memo-f))
  memoize-lru)

(define memoize-lru (make-lru-memoizer 100))

(in-test-group
 'memoize-lru
 (define (make-counter)
   (let ((count -1))
     (lambda (x)
       (set! count (+ count 1))
       count)))
 (define f1 (memoize-lru (make-counter)))
 (let loop ((i 0))
   (if (= i 100)
       'done
       (begin (f1 i)
	      (loop (+ i 1)))))
 (assert-= (f1 0) 0)
 (assert-= (f1 22) 22)
 (assert-= (f1 100) 100)
 (assert-= (f1 101) 101)
 (assert-= (f1 1) 102)
 (assert-= (f1 0) 0))

(define rule-memoize memoize-lru)
(load "rule-compiler")
(load "matcher")
(load "rule-simplifier")
(load "rules")

(define-each-test
  (assert-equal (algebra-2 '(* (+ y (+ z w)) x))
		'(+ (* w x) (* x y) (* x z)))
  (assert-equal (algebra-2 '(+ (* 3 (+ x 1)) -3))
		'(* 3 x)))

(run-registered-tests)
; 8 tests, 0 failures, 0 errors.