;
; This is essentially the program given by Ravi Sethi in "Programming
; Languages: Concepts and Constructs," which performs symbolic
; differentiation of a polynomial.
;
; First, establish an error code for bad parsing.
(errcode ERR_BADEXPR)
;
; The polynomials are represented in Lisp notation, so sums (+ ...)
; and produces are (* ...), etc. The top-level function decides what
; the sort of thing it's working on, and applies an appropriate worker
; function as below.
(define (d x E)
(cond
((constant? E) (diff-constant x E))
((variable? E) (diff-variable x E))
((sum? E) (diff-sum x E))
((product? E) (diff-product x E))
(#t (error ERR_BADEXPR "Cannot parse expression."))
)
)
;
; A constant, for our implementation, is an integer, and the differential
; of a constant is zero.
(setq constant? int?)
(define (diff-constant x E) 0)
;
; A variable is just a id atom, and the dx x = 1, dx y = 0.
(setq variable? id?)
(define (diff-variable x E)
(if (equal? x E) 1 0)
)
;
; Utilities for sums and products.
(define (terms E) (cdr E))
(define (factors E) (cdr E))
(define (sum? E)
(and (pair? E) (equal? '+ (car E)))
)
(define (product? E)
(and (pair? E) (equal? '* (car E)))
)
(define (make-sum x) (cons '+ x))
(define (make-product x) (cons '* x))
;
; The differential of a sum is the sum of the differentials:
; d (E1 + E2) = d E1 + d E2
(define (diff-sum x E)
(make-sum
(map (lambda (expr) (d x expr)) (terms E))
)
)
; This beast simply takes the terms of E, runs d x on each, then makes the
; sum of the result.
;
; The differential of a produce uses the chain rule:
; d E1 E2 = E1 d E2 + E2 d E1
; This is actually implemented by chain-rule; the diff-product function
; filters out the cases where the product has fewer than two factors.
(define (diff-product x E)
(let
; See how many things we're got.
((nfact (length (factors E))))
(cond
; No factors. Just a long-winded way to write the constant 1,
; whose differential is zero.
((equal? nfact 0) 0)
; One factor. Not really much of a product. Loose the multiply
; and take the differential of the single factor.
((equal? nfact 1) (d x (car (factors E))))
; Real case.
(#t (chain-rule x E))
)
)
)
;
; Here's the actual chain rule function.
; d E1 E2 = E1 d E2 + E2 d E1
(define (chain-rule x E)
(let
(
(E1 (car (factors E))) ; First factor.
(E2 (make-product (cdr (factors E)))) ; (* Other factors)
(dE1 (d x E1)) ; d E1
(dE2 (d x E2)) ; d E2
)
(make-sum
(list
(make-product (list E1 dE2))
(make-product (list E2 dE1))
)
)
)
)
;
; Some basic simplification. Not easy to do "completely," but this helps
; a lot.
;
; Top-level simplify.
(define (simplify E)
(cond
((sum? E) (simplify-sum E))
((product? E) (simplify-product E))
(#t E)
)
)
;
; The sum and product simplifiers are mainly calls to simpl, with some
; appropriate control parameters. The parameters are the corresponding
; identifier and make- function, and the identity for that operation.
(define (simplify-sum E)
(simpl sum? make-sum 0 E)
)
(define (simplify-product E)
(simpl product? make-product 1 E)
)
;
; Here's the simplifier.
(define (simpl isit? addop ident E)
(let
(
(parts (cdr E)) ; Terms or factors.
(sparts (map simplify parts)) ; Terms or factors simplified.
(fparts (flat isit? sparts)) ; Simp (* x (* y z)) to (* x y z)
(zout (replace-zero fparts)) ; Reduce (* ... 0 ...) to 0.
(unid (select (lambda (x) (not (equal? x ident))) zout))
; Remove identity (0 for + 1 for *)
)
(proper addop ident unid) ; Cleanup; see below.
)
)
;
; The flat function looks for subexpressions of the same operator and merges
; them in. For instance, change (+ x y (+ z w) (+ q 4) g) to
; (+ x y z w q 4 g).
(define (flat isit args)
(cond
((null? args) ()) ; Empty is empty.
((not (pair? args)) (list args)); I don't see how this happens, but ok.
((isit (car args)) ; If first arg same op, combine.
(append (flat isit (cdar args)) (flat isit (cdr args)))
)
(#t ; Default: go on to the next.
(cons (car args) (flat isit (cdr args)))
)
)
)
;
; This simply adds the operator back to a list of terms or factors, but it
; avoids turning the empty list into (+) or the singleton list int (* 17).
(define (proper addop ident args)
(cond
((null? args) ident) ; () becomes 0 or 1.
((null? (cdr args)) (car args)) ; (x) becomes x
(#t (addop args)) ; (x y z) to (+/* x y z)
)
)
;
; See if the expression is a multiplication containing zero (hence equal
; to zero).
(define (is-zero-mult? E)
(and (product? E)
(not (equal? (select (lambda (x) (equal? x 0)) (factors E)) ())) )
)
;
; Replace zero-valued multiply items with zero. This works only on
; the top level.
(define (replace-zero list)
(if (null? list) ()
(cons (if (is-zero-mult? (car list)) 0 (car list))
(replace-zero (cdr list))
)
)
)