;;;DERIV-SIMPLIFY-RULES.SCM                                 Oct. 23, 1998



;;;  REWRITE RULES FOR SIMPLIFYING ARITHMETIC EXPRESSIONS WITH DERIVATIVES

;;<EXPRESSION> ::= <INTEGER> | <VARIABLE> | (<EXPRESSION> + <EXPRESSION>) |
                   (<EXPRESSION> * <EXPRESSION>) |
                   (deriv <EXPRESSION> <VARIABLE>)


;;Evaluate (load "match.scm") -- the pattern matching code -- before
;;evaluating the definitions below.


                          ;RULES FOR DERIVATIVES


(define deriv+-rule
  (make-simple-rule '(deriv (?addend + ?augend) ?var)
                    '((deriv ?addend ?var) + (deriv ?augend ?var))))

(define deriv*-rule
  (make-simple-rule '(deriv (?plier * ?plicand) ?var)
                    '((?plicand * (deriv ?plier ?var))
                      +
                      (?plier * (deriv ?plicand ?var)))))

(define derivnum-rule
  (make-simple-rule '(deriv ?%num ?) 0))

(define derivsamevar-rule
  (make-simple-rule '(deriv ?var ?var) 1))

(define derivothervar-rule
  (make-general-rule '(deriv ?%var1 ?var)
                     (lambda (v1 v) (if (eq? v1 v) (fail) 0))))

(define deriv-rules
  (list deriv+-rule
        deriv*-rule
        derivnum-rule
        derivsamevar-rule
        derivothervar-rule))


                        ;;SIMPLIFICATION RULES

;converts any aritmetic expression into a standard-form sorted sum of
;sorted monomials

(define rule:prim+
  (make-general-rule
   '(?%num1 + ?%num2) +))

(define rule:prim*
  (make-general-rule
   '(?%num1 * ?%num2) *))

(define rule:+0
  (make-simple-rule '(?ad + 0) '?ad))

(define rule:0+                         ;redundant with +nums-right
  (make-simple-rule '(0 + ?au) '?au))

(define rule:0*
  (make-simple-rule '(0 * ?plicand) 0))

(define rule:*0                         ;redundant with *nums-left
  (make-simple-rule '(?plier * 0) 0))

(define rule:1*
  (make-simple-rule '(1 * ?plicand) '?plicand))

(define rule:*1                         ;redundant with *nums-left
  (make-simple-rule '(?plier * 1) '?plier))

(define rule:left-distrib
  (make-simple-rule '(?plier * (?ad + ?au))
                    '((?plier * ?ad) + (?plier * ?au))))

(define rule:right-distrib
  (make-simple-rule '((?ad + ?au) * ?plier)
                    '((?plier * ?au) + (?plier * ?ad))))

(define rule:+assoc                     ;right
  (make-simple-rule    
   '((?e + ?f) + ?g) '(?e + (?f + ?g))))

(define rule:*assoc                     ;right
  (make-simple-rule    
   '((?e * ?%not-num) * ?g) '(?e * (?%not-num * ?g))))

(define rule:+nums-right
  (make-simple-rule '(?%num + ?%not-num)
                    '(?%not-num + ?%num)))

(define rule:*nums-left1
  (make-simple-rule '(?%var * ?%num)
                    '(?%num * ?%var)))

(define rule:*nums-left2
  (make-simple-rule
   '(?%var * (?%num * ?e))
   '(?%num * (?%var * ?e))))

(define rule:*nums-left3
  (make-simple-rule
   '(?%num1 * (?%num2 * ?e))
   '((?%num1 * ?%num2) * ?e)))


(define rule:varsort1
  (make-general-rule
   '(?%var2 * ?%var1)
   (lambda (v2 v1)
     (if (symbol<? v1 v2)
         `(,v1 * ,v2)
         (fail)))))

(define rule:varsort2
  (make-general-rule
   '(?%var2 * (?%var1 * ?e))
   (lambda (v2 v1 e)
        (if (symbol<? v1 v2)
            `(,v1 * (,v2 * ,e))
            (fail)))))


(define rule:sort-prods1
  (make-general-rule
   '(?%prod1 + ?%prod2)
   (lambda (p1 p2)
     (if (prod<? p1 p2)
         `(,p2 + ,p1)
         (fail)))))

(define rule:sort-prods2
  (make-general-rule
   '(?%prod1 + (?%prod2 + ?e))
   (lambda (p1 p2 e)
     (if (prod<? p1 p2)
         `(,p2 + (,p1 + ,e))
         (fail)))))


(define (prod<? p1 p2)
  (define (monomial<? m1 m2 flag)
                    ;FLAG must be #t, #f, or '=.
                    ;(MONOMIAL<? m1 m2 flag) returns
                    ;#t if degree(m1) < degree(m2)
                    ;#f if degree(m2) < degree(m1)
                    ;and when degree(m1) = degree(m2):
                    ;FLAG when FLAG is a Boolean,
                    ;and otherwise, ie, when Flag
                    ;is '=, it returns '=, #t, or #f
                    ;according as M1 is lexically identical
                    ;to, less than, or greater than M2.
    (cond
     ((and (pair? m1) (pair? m2))
               ;NEW-FLAG will be returned if M1 and M2
               ;turn out to have the same degree:
      (let ((new-flag
             (if (boolean? flag)
                 flag
                 (let ((var1 (car m1))  ;FLAG is '=
                       (var2 (car m2)))
                         ;the lexical order of M1, M2 would be
                         ;determined by their leading variables
                   (if (eq? var1 var2)
                       '=
                       (symbol<? var1 var2))))))
        (monomial<? (caddr m1) (caddr m2) new-flag)))
     ((symbol? m1)                      ;degree(m1) = 1 
      (if (symbol? m2)
          (cond                         ;degree(m2) = 1
           ((boolean? flag) flag)
           ((eq? m1 m2) '=)
           (else (symbol<? m1 m2)))
          #t))                          ;degree(m2) > 1
     ((symbol? m2) #f)                  ;degree(m2) = 1 < degree(m1)
     (else (error "MONOMIAL<?: ill-formed monomial" m1 m2))))
  (cond
   ((number? p2) (and (number? p1) (< p1 p2)))
   ((number? p1) #t)
   (else
    (let ((p1-has-coeff? (and (pair? p1) (number? (car p1))))
          (p2-has-coeff? (and (pair? p2) (number? (car p2)))))
      (let ((monomial1 (if p1-has-coeff? (caddr p1) p1))
            (monomial2 (if p2-has-coeff? (caddr p2) p2)))
        (let ((monomial-comparison
               (monomial<? monomial1 monomial2 '=)))
          (if (eq? monomial-comparison '=)
                                        ;p1, p2 have same monomial part:
              (if (and p1-has-coeff? p2-has-coeff?)
                  (< (car p1) (car p2))
                  p2-has-coeff?)        ;p1 does not have a coefficient
              monomial-comparison)))))))
           

(define (sorted-right-product? datum)
  (or (number? datum)
      (sorted-right-monomial? datum)
      (match? '(?%num * ?%smonml) datum)))


(define (sorted-right-monomial? datum)
  (or (match? '?%var datum)
      (let ((dicts (match '(?%var1 * ?%var2) datum)))
        (and (pair? dicts)
             (symbol<=? (lookup '?%var1 (car dicts))
                        (lookup '?%var2 (car dicts)))))
      (and (match? '(?%var * ?%smonml) datum)
           (let ((dicts (match '(?%var1 * (?%var2 * ?)) datum)))
             (and (pair? dicts)
                  (symbol<=? (lookup '?%var1 (car dicts))
                             (lookup '?%var2 (car dicts))))))))

(define (symbol<? symbol1 symbol2)
  (string<? (symbol->string symbol1) 
            (symbol->string symbol2)))

(define (symbol<=? symbol1 symbol2)
  (or (eq? symbol1 symbol2)
      (symbol<? symbol1 symbol2)))

(define rule:sm+sm1st
  (make-simple-rule '(?%smonml + ?%smonml)
                    '(2 * ?%smonml)))

(define rule:sm+sm2nd
  (make-simple-rule '(?%smonml + (?%smonml + ?e))
                    '((2 * ?%smonml) + ?e)))

(define rule:p+sm1st
  (make-simple-rule '((?%num * ?%smonml) + ?%smonml)
                    '((?%num + 1) * ?%smonml)))

(define rule:p+sm2nd
  (make-simple-rule '((?%num * ?%smonml) + (?%smonml + ?e))
                    '(((?%num + 1) * ?%smonml) + ?e)))


(define rule:p+p1st
  (make-simple-rule '((?%num1 * ?%smonml) + (?%num2 * ?%smonml))
                    '((?%num1 + ?%num2) * ?%smonml)))

(define rule:p+p2nd
  (make-simple-rule '((?%num1 * ?%smonml) + ((?%num2 * ?%smonml) + ?e))
                    '(((?%num1 + ?%num2) * ?%smonml) + ?e)))


;Wierd and sound, but fortunately not needed:
;(define rule:cntxt+
;  (make-simple-rule '(($%nonhole ?%nonzero-num) + ($%nonhole ?%num2))
;                    '(($%nonhole 0) + ($%nonhole (?%nonzero-num + ?%num2)))))

;(set! restriction-table           ;define RESTRICTION-TABLE before this SET!
;      (cons `($%nonhole
;              ,(lambda (datum) (not (equal? datum hole))))
;            (cons
;             `(?%nonzero-num
;               ,(lambda (dat) (and (number? dat) (not (zero? dat)))))
;             restriction-table)))


(define primitive-arith-rules
  (list rule:prim+
        rule:prim*
        rule:+0
        rule:0+
        rule:0*
        rule:*0
        rule:1*
        rule:*1))


(define simplify-rules
  (list rule:prim+ rule:prim*
        rule:+0 rule:0* rule:1*         ;omit the other three 0\1 rules
        rule:left-distrib rule:right-distrib
        rule:+assoc rule:*assoc
        rule:+nums-right
        rule:*nums-left1 rule:*nums-left2 rule:*nums-left3
        rule:varsort1 rule:varsort2
        rule:sort-prods1 rule:sort-prods2
        rule:sm+sm1st rule:sm+sm2nd
        rule:p+sm1st rule:p+sm2nd
        rule:p+p1st rule:p+p2nd))


(define restriction-table
  (let ((not-number? (lambda (dat) (not (number? dat)))))
    `((?%num        ,number?)
      (?%num1       ,number?)
      (?%num2       ,number?)
      (?%not-num    ,not-number?)
      (?%var        ,symbol?)
      (?%var1       ,symbol?)
      (?%var2       ,symbol?)
      (?%prod ,sorted-right-product?)
      (?%prod1 ,sorted-right-product?)
      (?%prod2 ,sorted-right-product?)
      (?%smonml ,sorted-right-monomial?)
      (?%smonml1 ,sorted-right-monomial?)
      (?%smonml2 ,sorted-right-monomial?))))


;;                             EXAMPLES

;(define datum '((2 + (a * a)) * (1 + 0)))

;(define easy-test '(deriv (a * (2 + (a * a))) a))

;(everywhere-final-forms deriv-rules easy-test)
;;((((2 + (a * a)) * 1) + (a * (0 + ((a * 1) + (a * 1))))))


;(define test-deriv '(deriv ((a + b) * (2 + (a * a))) a))

;(one-everywhere-final-form deriv-rules test-deriv)
;;Value: (((2 + (a * a)) * (1 + 0)) + ((a + b) * (0 + ((a * 1) + (a * 1)))))

;(one-topdown-final-form deriv-rules test-deriv)
;;Value: (((2 + (a * a)) * (1 + 0)) + ((a + b) * (0 + ((a * 1) + (a * 1)))))

;(one-everywhere-final-form simplify-rules
;     '(((2 + (a * a)) * (1 + 0)) + ((a + b) * (0 + ((a * 1) + (a * 1))))))
;;Value: ((2 * (a * b)) + ((3 * (a * a)) + 2))

;(one-everywhere-final-form
; primitive-arith-rules
; '(((2 + (a * a)) * (1 + 0)) + ((a + b) * (0 + ((a * 1) + (a * 1))))))
;;Value: ((2 + (a * a)) + ((a + b) * (a + a)))

;(one-bottomup-final-form
; primitive-arith-rules
; '(((2 + (a * a)) * (1 + 0)) + ((a + b) * (0 + ((a * 1) + (a * 1))))))
;;Value: ((2 + (a * a)) + ((a + b) * (a + a)))

;(one-everywhere-final-form
;    (append deriv-rules simplify-rules) test-deriv)
;;Value: ((2 * (a * b)) + ((3 * (a * a)) + 2))

;(one-everywhere-final-form simplify-rules
;                           '(((x + (2 * y)) * z) + ((x + (7 * y)) * z)))
;;Value: ((9 * (y * z)) + (2 * (x * z)))

;(everywhere-final-forms simplify-rules
;                        '((x + ((2 * y) + z)) + (x + ((7 * y) + z))))
;;Value: (((2 * z) + ((9 * y) + (2 * x))))    ;1000 node-hits, 431 distinct nodes

;(one-everywhere-final-form simplify-rules
;     '(((3 + a) * (a + (b +(a * -4)))) + ((a + b) * ((b * c) * (a + a)))))
;;((2 * (a * (b * (b * c))))
;; +
;; ((2 * (a * (a * (b * c))))
;;  +
;;  ((a * b) + ((-3 * (a * a)) + ((3 * b) + (-9 * a))))))

;(one-everywhere-final-form simplify-rules
;     '((x * (y + (3 + 4))) * (x + (3 + y))))
;;((x * (y * y))
;; +
;; ((x * (x * y)) + ((10 * (x * y)) + ((7 * (x * x)) + (21 * x)))))