-------------
Problem 4.1:

Why is the (expr<? a b) restriction necessary in the commutative law?
What would go wrong if the there was no restriction? (Indicated by the
symbol "none" in the restriction slot of the rule.)
-------------

Without this restriction, the system would have no way to know that it was
done simplifying.  Commuting two values would always be an appropriate action,
and it would do that over and over and likely never make any other progress.


-------------
Problem 4.2:

In the second system how does the use of the ordering on expressions
imposed on the commutative laws make the numerical simplification
rules effective?

Suppose that the commutative laws did not force an ordering, how would
we have to write the numerical simplification rules?  Explain why
numerical simplification would become very expensive.
-------------

Without a fixed ordering on the terms and factors that would automatically
place the coefficients at the front and the terms to be combined adjacent to
each other, you would have to search through every product for factors,
comparing all factors of all terms to see if they could be reconciled.  For
instance, in the case of:

    (+ y (* x -2 w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3))

in order to discover that (* x 4 y) and (* x y 3) were commensurable, all
pairs of terms (order n^2) would need to be directly compared, which would
itself entail another (order n^2) procedure in which one term was repeatedly
scanned and pruned for the factors in the other term.

-------------
Problem 4.3:

The ordering in the commutative laws evolves an n^2 bubble sort on the
terms of a sum and the factors of a product.  This can get pretty bad
if there are many terms, as in a serious algebra problem.  Is there
some way in this system to make a more efficient sort?  If not, why
not?  If so, how would you arrange it?
-------------

Right now it would be difficult -- the pattern matcher would need to be
substantially rewritten, since it currently doesn't give access to the contents
of the matched sequences the way it does the contents of the matched elements.
Given that rewriting, it would be fairly trivial:

    (rule (+ (?? a))
          ((not (monotonic? expr<? a)))
          (cons + (sort expr<? a)))

-------------
Problem 4.4:

The system we have described does not collect like terms.  For example:

(algebra-2 '(+ (* 4 x) (* 3 x)))
Value (+ (* 3 x) (* 4 x))

Add rules that cause the collection of like terms, leaving the result
as a sum of terms.  Demonstrate your solution.  Your solution must be
able to handle problems like:

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

Problem 4.5:

Problem 3.27 in SICP (pp. 272--273) shows the basic idea of
memoization.  Can this help the simplifier?  How?  

Write a memoizer that may be useful in dealing with expressions in the
rule-simplifier procedure.  One problem is that we don't want to store
a table with an unbounded number of big expression.  However, most of
the advantage in this kind of memoizer comes from using it as a cache
for recent results.  Implement an LRU memoizer mechanism that stores
only a limited number of entries and throws away the Least-Recently
Used one.  Demonstrate your program.
-------------

#|
(algebra-3
 '(+ y (* x -2 w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3)))

;>> insert-lru-pair: ((+ y (* x -2 w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3)) (+ y (* 6 z) (* 7 x y)))
;Value: (+ y (* 6 z) (* 7 x y))

(algebra-3
 '(+ y (* x -2 w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3)))

;Value: (+ y (* 6 z) (* 7 x y))
|#

-------------
Problem 4.6:

In Problem Set #3, problem 3.4, you constructed a combinator for
reversed segments and used it to implement a palindrome predicate.
The reversed segments were indicated by "$$" variables.  Install your
reversed segment matching combinators into the matcher (You already
did this in problem set #3.) and build the syntactic apparatus for $$
variables in the rule compiler for this problem set.  Demonstrate your
additions.
-------------

;; other code in matcher.scm and rule-compiler.scm

(define algebra-4
  (rule-simplifier
   (list

;;; Reversed Term Patterns
;;($$ a)
    (rule (+ (?? a) ($$ a))
          none
          (* 2 (+ (?? a))))
    
    )))

(algebra-4
 '(+ a b c c b a))
insert-lru-pair: ((+ a b c c b a) (* 2 (+ a b c)))
;Value: (* 2 (+ a b c))

(algebra-4
 '(+ a b c c b a))
;Value: (* 2 (+ a b c))

;;;;
;;;; load.scm
;;;;

(set-working-directory-pathname! "~/classes/symbolic/psets/04")

(fluid-let ((*parser-canonicalize-symbols?* #t))
  (load "rule-compiler")
  (load "matcher")
  (load "rule-simplifier")
  (load "rules")
  (load "lru-table")
  (load "new-rules"))

;;;;
;;;; matcher.scm (changed parts only)
;;;;


(define (match:reversed-segment variable)
  (define (reversed-segment-match data dictionary succeed)
    (and (list? data)
         (let ((vcell (match:lookup variable dictionary)))
           (and vcell
                (let* ((val (match:value vcell))
                       (len (length val)))
                  (and (>= (length data)
                           len)
                       (equal? (list-head data len)
                                (reverse val))
                       (succeed dictionary len)))))))
  reversed-segment-match)

(define (match:reversed-segment? pattern)
  (and (pair? pattern)
       (eq? (car pattern) '$$)))

(define (match:->combinators pattern)
  (define (compile pattern)
    (cond ((match:element? pattern)
           (if (= (length pattern) 2)
               (match:element (match:variable-name pattern))
               (match:element-restricted (match:variable-name pattern)
                                         (match:predicate pattern))))
          ((match:segment? pattern)
           (match:segment (match:variable-name pattern)))
          ((match:reversed-segment? pattern)
           (match:reversed-segment (match:variable-name pattern)))
          ((list? pattern)
           (apply match:list (map compile pattern)))
          (else (match:eqv pattern))))
  (compile pattern))

;;;;
;;;; rule-compiler.scm (changed parts only)
;;;;


(define (pattern-names pattern)
  (let loop ((pattern pattern) (names '()))
    (cond ((or (match:element? pattern)
               (match:segment? pattern)
               (match:reversed-segment? pattern))
           (let ((name (match:variable-name pattern)))
             (if (memq name names)
                 names
                 (cons name names))))
          ((list? pattern)
           (let elt-loop ((elts pattern) (names names))
             (if (pair? elts)
                 (elt-loop (cdr elts) (loop (car elts) names))
                 names)))
          (else names))))

(define (compile-pattern pattern env)
  (let loop ((pattern pattern))
    (cond ((match:element? pattern)
           (if (match:restricted? pattern)
               `(match:element ',(match:variable-name pattern)
                               ,(match:restriction pattern))
               `(match:element ',(match:variable-name pattern))))
          ((match:segment? pattern)
           `(match:segment ',(match:variable-name pattern)))
          ((match:reversed-segment? pattern)
           `(match:reversed-segment ',(match:variable-name pattern)))
          ((null? pattern)
           `(match:eqv '()))
          ((list? pattern)
           `(match:list ,@(map loop pattern)))
          (else
           `(match:eqv ',pattern)))))


;;;;
;;;; lru-table.scm
;;;;

;;; least-recently-used associative mechanism

(define-structure
  (lru-table
   (constructor
    make-lru-table
    (#!optional max
                same?
                fail
                alist)))
  (max 256)
  (same? eqv?)
  (fail 'lru-table/fail)
  (alist '()))

#|
(define (re-splice in out)
  (let loop ((in in)
             (out out))
    (if (null? out)
        in
        (loop (cons (car out)
                    in)
              (cdr out)))))

(re-splice '(5 6 7)
           '(4 3 2 1))
;Value: (1 2 3 4 5 6 7)
|#

(define (lru-table/get lru-table key #!optional fail)
  (define (re-splice in out)
    (let loop ((in in)
               (out out))
      (if (null? out)
          in
          (loop (cons (car out)
                      in)
                (cdr out)))))
  (let ((same? (lru-table-same? lru-table)))
    (let loop ((in (lru-table-alist lru-table))
               (out '()))
      (if
       (null? in)
       (if (default-object? fail)
           (lru-table-fail lru-table)
           fail)
       (let ((current (car in)))
         (if (same? key
                    (car current))
             (begin
               (set-lru-table-alist!
                lru-table
                (cons current
                      (re-splice (cdr in)
                                 out)))
               (cadr current))
             (loop (cdr in)
                   (cons current out))))))))

(define (lru-table/put! lru-table key datum)
  (let ((old-datum? (lru-table/get lru-table key)))
    (let ((alist (lru-table-alist lru-table))
          (max (lru-table-max lru-table))
          (same? (lru-table-same? lru-table))
          (fail (lru-table-fail lru-table)))
      (set-lru-table-alist!
       lru-table
       (cons
        (list key datum)
        (cond
         ((not
           (same? old-datum?
                  fail))
          (cdr alist))
         ((>= (length alist) max)
          (list-head alist
                     (- max 1)))
         (else
          alist)))))))

(define (lru-table/remove! lru-table key)
  (let ((old-datum? (lru-table/get lru-table key)))
    (let ((alist (lru-table-alist lru-table))
          (same? (lru-table-same? lru-table))
          (fail (lru-table-fail lru-table)))
      (if (not
           (same? old-datum?
                  fail))
          (set-lru-table-alist!
           lru-table
           (cdr alist))))))

#|
(begin
  (define bar
  (make-lru-table 7
                  eqv?
                  'bar-fail
                  '((1 a) (2 b) (3 c) (4 d) (5 e))))
(lru-table-alist bar))
;Value: ((1 a) (2 b) (3 c) (4 d) (5 e))

(begin
  (lru-table/put! bar 6 'f)
  (lru-table-alist bar))
;Value: ((6 f) (1 a) (2 b) (3 c) (4 d) (5 e))

(begin
  (lru-table/put! bar 5 'x)
  (lru-table-alist bar))
;Value: ((5 x) (6 f) (1 a) (2 b) (3 c) (4 d))

(begin
  (lru-table/get bar 3)
  (lru-table-alist bar))
;Value: ((3 c) (5 x) (6 f) (1 a) (2 b) (4 d))

(lru-table/get bar 7)
;Value: bar-fail

(lru-table/get bar 7 'non-default-fail)
;Value: non-default-fail

(begin
  (lru-table/get bar 7)
  (lru-table-alist bar))
;Value: ((3 c) (5 x) (6 f) (1 a) (2 b) (4 d))

(begin
  (lru-table/put! bar 7 'g)
  (lru-table-alist bar))
;Value: ((7 g) (3 c) (5 x) (6 f) (1 a) (2 b) (4 d))

(begin
  (lru-table/put! bar 8 'h)
  (lru-table-alist bar))
;Value: ((8 h) (7 g) (3 c) (5 x) (6 f) (1 a) (2 b))

(begin
  (lru-table/put! bar 9 'i)
  (lru-table-alist bar))
;Value: ((9 i) (8 h) (7 g) (3 c) (5 x) (6 f) (1 a))

(begin
  (lru-table/remove! bar 5)
  (lru-table-alist bar))
;Value: ((9 i) (8 h) (7 g) (3 c) (6 f) (1 a))
|#


;;;;
;;;; new-rules.scm (changed parts only)
;;;;

(define (variable? expr)
  (and (list expr)
       (eqv? (car expr)
             '%variable%)))
(define variable-value cdr)

(define (sum? expr)
  (and (list? expr)
       (eqv? (car expr)
             '+)))

(define (product? expr)
  (and (list? expr)
       (eqv? (car expr)
             '*)))

(define (list<? test<)
  (lambda (lis-1 lis-2)
    (let ((len-1 (length lis-1))
          (len-2 (length lis-2)))
      (cond ((< len-1 len-2) #t)
            ((> len-1 len-2) #f)
            (else
             (let lp ((x lis-1)
                      (y lis-2))
               (cond ((null? x) #f)     ; same
                     ((test< (car x) (car y)) #t)
                     ((test< (car y) (car x)) #f)
                     (else (lp (cdr x) (cdr y))))))))))
#|
((list<? <)
 '(0 1 2 3)
 '(0 1 2 4))
;Value: #t

((list<? <)
 '(0 1 2 4)
 '(0 1 2 3))
;Value: #f

((list<? <)
 '(0 1 2 4)
 '(0 1 2 3 5))
;Value: #t
|#


(define (expr<? x y)
  (cond ((or (product? x)
             (product? y))
         (let ((var-x (strip-coefficient x))
               (var-y (strip-coefficient y))
               (n-x (coefficient x))
               (n-y (coefficient y)))
           (cond ((expr<? var-x var-y)
                  #t)
                 ((expr<? var-y var-x)
                  #f)
                 (else
                  (< n-x n-y)))))
        
        ((number? x)
         (if (number? y)
             (< x y)
             #t))
        ((number? y) #f)
        
        ((symbol? x)
         (if (symbol? y)
             (symbol<? x y)
             #t))
        ((symbol? y) #f)

        ((variable? x)
         (if (variable? y)
             ((list<? expr<?)
              (cdr x)
              (cdr y))
             #t))
        ((variable? y) #f)

        ((and (sum? x)
              (sum? y))
         ((list<? expr<?)
          (cdr x)
          (cdr y)))
        
        (else
         (error "Unknown expression type -- expr<?"
                x y))))


(define (strip-coefficient term)
  (cond ((number? term)
         1)
        ((not (product? term))
         term)
        ((number? (cadr term))
         (if (= 1 (length (cddr term)))
             (caddr term)
             (cons '%variable%
                   (cddr term))))
        (else
         (cons '%variable%
               (cdr term)))))

#|
(strip-coefficient 3)
; 1

(strip-coefficient 'x)
; x

(strip-coefficient '(+ 3 x))
; (+ 3 x)

(strip-coefficient '(* 3 x y))
; (* x y)

(strip-coefficient '(* 3 x))
; x
|#

(define (coefficient term)
  (cond ((number? term)
         term)
        ((not (product? term))
         1)
        ((number? (cadr term))
         (cadr term))
        (else
         1)))

#|
(coefficient 3)
; 3

(coefficient 'x)
; 1

(coefficient '(+ 2 x))
; 1

(coefficient '(* 2 x))
; 2
|#

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

    (rule (+ (?? a)
             (* (? n1) (?? x))
             (* (? n2) (?? x))
             (?? b))
          (and (number? n1)
               (number? n2))
          (+ (?? a)
             (* (+ (? n1) (? n2))
                (?? x))
             (?? b)))

    (rule (+ (?? a)
             (* (?? x))
             (* (? n2) (?? x))
             (?? b))
          (number? n2)
          (+ (?? a)
             (* (+ 1 (? n2))
                (?? x))
             (?? b)))

    (rule (+ (?? a)
             (?? x)
             (* (? n2) (?? x))
             (?? b))
          (number? n2)
          (+ (?? a)
             (* (+ 1 (? n2))
                (?? x))
             (?? b)))

    (rule (+ (?? a)
             (* (? n1) (?? x))
             (* (?? x))
             (?? b))
          (number? n1)
          (+ (?? a)
             (* (+ 1 (? n1))
                (?? x))
             (?? b)))
    
    (rule (+ (?? a)
             (* (? n1) (?? x))
             (?? x)
             (?? b))
          (number? n1)
          (+ (?? a)
             (* (+ 1 (? n1))
                (?? x))
             (?? 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)))

    )))

#|
(algebra-3 '(* (+ y (+ z w)) x))
;Value: (+ (* w x) (* x y) (* x z))

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

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

(define (monotonic? test lis)
  (let loop ((lis lis))
    (cond ((or (null? lis)
               (null? (cdr lis)))
           #t)
          ((not (test (car lis)
                      (cadr lis)))
           #f)
          (else
           (loop (cdr lis))))))

(define (rule-memoize simplify)
  (let ((table (make-lru-table 10 equal?)))
    (lambda (expr)
      (let ((old-datum (lru-table/get table expr #f)))
        (or old-datum
            (let ((result (simplify expr)))
              (begin
                (write-string "insert-lru-pair: ")
                (write (list expr result))
                (newline)
                (lru-table/put! table expr result))
              result))))))




#|
(algebra-3
 '(+ y (* x -2 w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3)))

;>> insert-lru-pair: ((+ y (* x -2 w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3)) (+ y (* 6 z) (* 7 x y)))
;Value: (+ y (* 6 z) (* 7 x y))

(algebra-3
 '(+ y (* x -2 w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3)))

;Value: (+ y (* 6 z) (* 7 x y))


(define algebra-4
  (rule-simplifier
   (list

;;; Reversed Term Patterns
;;($$ a)
    (rule (+ (?? a) ($$ a))
          none
          (* 2 (+ (?? a))))
    
    )))

(algebra-4
 '(+ a b c c b a))
|#