Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/oper_sys/weyl/weyl_lsp.lha/general.lisp

Text File | 1991-10-19 | 30.8 KB | 1,003 lines

;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
;;; ===========================================================================
;;;                  General Representation
;;; ===========================================================================
;;; (c) Copyright 1989, 1991 Cornell University

;;; $Id: general.lisp,v 1.21 1991/10/19 03:40:53 rz Exp $

(in-package "WEYLI")

(defclass has-memoization ()
     ((memos :initform (make-hash-table :test #'eq))))

(defmethod set-memoization ((domain has-memoization) key value)
  (with-slots (memos) domain
    (setf (gethash key memos) value)
    value))

(defmethod get-memoization ((domain has-memoization) key)
  (with-slots (memos) domain
    (gethash key memos)))

(defsetf get-memoization set-memoization)

(defmacro memoize (domain expression &body body)
  `(let ((.expr. ,expression))
    (with-slots (memos) ,domain
       (multiple-value-bind (value found?) (gethash .expr. memos)
     (if found? value
         (setf (get-memoization ,domain .expr.) (progn ,@body)))))))

(defclass general-expressions (domain has-memoization)
     ((variables :initform ()
         :accessor ge-variables)
      (context :initform ()
           :accessor ge-context)))

(defvar *general* ()
  "The general representation domain")

(defmethod domain-of ((element symbol))
  *general*)

(defmethod domain-of ((x list))
  *general*)

;; Variables and contexts

;; A variable is a list that starts with the atom VARIABLE.  Atoms are
;; canonicalized to this form

(defun make-variable (var)
  (setq var
    (cond ((atom var)
           (list 'variable :symbol var))
          (t
           (list 'variable :symbol var))))
  (setf (getf (rest var) :string) (create-variable-string var))
  var)

(defun create-variable-string (var)
  (let ((string (cond ((atom (getf (rest var) :symbol))
               (string-downcase (getf (rest var) :symbol)))
              (t (format nil "[~A]" (getf (rest var) :symbol)))))
    temp)
    (when (setq temp (getf (rest var) :subscripts))
      (setq string
        (format nil "~A(~S~{,~S~})"
            string (first temp) (rest temp))))
    string))


;; This function is only to be applied to general expressions.
(defsubst ge-variable? (x)
  (and (not (atom x)) (eql (first x) 'variable)))

(defmethod add-subscripts ((var symbol) &rest subscripts)
  (%apply #'add-subscripts (coerce var *general*) subscripts))

(defmethod add-subscripts ((var list) &rest subscripts)
  (setq var (coerce var *general*))
  (let* ((symbol (getf (rest var) :symbol))
     (subscripts (append (getf (rest var) :subscripts)
                 #+Genera (copy-list subscripts)
                 #-Genera subscripts))
     (canonical-var
      (member symbol (ge-variables *general*)
          :test (lambda (a b)
              (and (equal a (getf (rest b) :symbol))
                   (equal subscripts
                      (getf (rest b) :subscripts)))))))
    (cond (canonical-var
       (first canonical-var))
      (t (setq var (list 'variable :symbol symbol
                 :subscripts subscripts))
         (setf (getf (rest var) :string) (create-variable-string var))
         (push var (ge-variables *general*))
         var))))

(defun initialize-contexts ()
  (setq *general* (make-instance 'general-expressions)))

(defmacro with-new-context (&body body)
  `(let ((*general* (make-instance 'general-expressions)))
     ,@body))

(defmacro check-point-context (&body body)
  `(let ((.old-variables. (ge-variables *general*))
     (.old-context. (ge-context *general*)))
     (unwind-protect (progn ,@body)
       (setf .old-variables. (ge-variables *general*))
       (setf .old-context. (ge-context *general*)))))

(defmethod coerce ((var number) (domain general-expressions))
  var)

(defmethod coerce ((var symbol) (domain general-expressions))
  (let ((canonical-var
     (member var (ge-variables domain)
         :test (lambda (a b)
             (and (equal a (getf (rest b) :symbol))
                  (null (getf (rest b) :subscripts)))))))
    (if canonical-var
    (first canonical-var)
    (first
     (push (make-variable var) (ge-variables domain))))))

(defmethod coerce ((var list) (domain general-expressions))
  (cond ((eql (first var) 'variable)
     (let ((canonical-var
        (member var (ge-variables domain) :test #'eql)))
       (first
        (if canonical-var canonical-var
        (push var (ge-variables domain))))))
    ((get (first var) :ge-coerce)
     (%funcall (get (first var) :ge-coerce) var domain))
    ((get (first var) :ge-operator)
     `(,(get (first var) :ge-operator)
        ,@(loop for x in (rest var) collect (coerce x domain))))
    (t
     `(,(first var)
        ,@(loop for x in (rest var) collect (coerce x domain))))))

(defmethod get-variable-property ((domain general-expressions) var key)
  (setq var (coerce var domain))
  (loop for var-prop in (ge-context domain)
    do (when (eql (first var-prop) var)
         (return (getf (rest var-prop) key)))
    finally (progn
          (push (list var) (ge-context domain))
          (return nil))))

(defmethod set-variable-property ((domain general-expressions) var key value)
  (setq var (coerce var domain))
  (loop for var-prop in (ge-context domain)
    do (when (eql (first var-prop) var)
         (setf (getf (rest var-prop) key) value)
         (return value))
    finally (progn
          (push (list var key value) (ge-context domain))
          (return value))))

(defsetf get-variable-property set-variable-property)

(defmethod declare-dependencies ((var (or symbol list)) &rest vars)
  (setq var (coerce var *general*))
  (let ((depends (get-variable-property *general* var :dependencies)))
    (loop for v in vars
      do (setq v (coerce v *general*))
         (unless (member v depends :test #'ge-equal)
           (push v depends)))
    (setf (get-variable-property *general* var :dependencies)
      depends)))

(defmethod depends-on? ((exp number) &rest vars)
  (declare (ignore vars))
  nil)

(defmethod depends-on? ((exp (or symbol list)) &rest vars)
  (setq exp (coerce exp *general*))
  (setq vars (loop for v in vars
           collect (coerce v *general*)))
  (labels ((depends (exp v)
         (cond ((number? exp) nil)
           ((ge-variable? exp)
            (let ((depends (get-variable-property
                    *general* exp :dependencies)))
              (if (or (ge-equal v exp)
                  (member v depends :test #'ge-equal))
              t nil)))
           ((member (first exp) '(deriv))
            (depends (second exp) v))
           (t;; (member (first exp) '(plus times expt))
            (loop for x in (rest exp)
              do (when (depends x v)
                   (return t))
              finally (return nil))))))
    (loop for v in vars
      do (unless (depends exp v)
           (return nil))
      finally (return t))))

(defmethod different-kernels ((exp number) (kernels list))
  nil)

(defmethod different-kernels ((exp symbol) (kernels list))
  (setq exp (coerce exp *general*))
  (setq kernels (loop for k in kernels collect (coerce k *general*)))
  (unless (member exp kernels :test #'ge-equal)
    (list exp)))

(defmethod different-kernels ((exp list) (kernels list))
  (setq exp (coerce exp *general*))
  (setq kernels (loop for k in kernels collect (coerce k *general*)))
  (let ((new ()))
    (labels ((check-kernel (x)
           (unless (or (number? x)
               (member x kernels :test #'ge-equal))
         (pushnew x new :test #'ge-equal)))
         (new-kernel (x)
           (cond ((ge-variable? x)
              (check-kernel x))
             ((or (ge-plus? x) (ge-times? x))
              (loop for exp in (rest x)
                do (new-kernel exp)))
             ((ge-expt? x)
              (if (lisp::integerp (third x))
              (new-kernel (second x))
              (check-kernel x)))
             (t (check-kernel x)))))
      (new-kernel exp)
      new)))
(defun print-variable (variable &optional (stream *standard-output*))
  (setq variable (coerce variable *general*))
  (let ((sym (getf (rest variable) :string)))
    (cond ((and (not (null sym)) (atom sym))
       #+Genera
       (format stream "~'i~A~" sym)
       #-Genera
       (princ sym stream))
      (t (princ (getf (rest variable) :symbol) stream)))))

(defmethod display ((expr number) &optional (stream *standard-output*)
            &rest ignore)
  (declare (ignore ignore))
  (princ expr stream)
  (values))

(defmethod display ((expr symbol) &optional (stream *standard-output*)
            &rest ignore)
  (declare (ignore ignore))
  (setq expr (coerce expr *general*))
  (display expr stream))

(defmacro def-display-fn (op arglist &body body)
  (let ((fun-name (intern (format nil "DISPLAY-~A" op))))
    (unless (lisp::= 2 (length arglist))
      (error "Wrong number of arguments for DISPLAY function: ~S" op))
    `(progn (setf (get ',op 'display-function) ',fun-name)
        (defun ,fun-name ,arglist ,@body (values)))))

(defmethod display ((expr list) &optional (stream *standard-output*)
            &rest ignore)
  (declare (ignore ignore))
  (let (fun)
    (cond ((eql 'variable (first expr))
       (print-variable expr stream))
      ((setq fun (get (first expr) 'display-function))
       (%funcall fun expr stream))
      (t (format stream "~A{" (string-downcase (first expr)))
         (display-list (rest expr) stream)
         (princ "}" stream))))
  (values))

(defun parenthesized-display (expr stream)
  (princ "(" stream)
  (display expr stream)
  (princ ")" stream))

(defun safe-display (expr stream)
  (if (or (number? expr)
      (ge-variable? expr)
      (ge-expt? expr))
      (display expr stream)
      (parenthesized-display expr stream)))

;; Display a list of objects, paying attention to *print-length*.  No
;; surrounding delimiters.   This is a method so that we can define
;; similar functions for sets of objects embedded in arrays.
(defmethod display-list
    ((objects list) &optional (stream *standard-output*))
  (when objects
    (let ((cnt (or *print-length* -1)))
      (declare (fixnum cnt))
      (display (first objects) stream)
      (lisp:decf cnt)
      (loop for var in (rest objects)
        do (princ ", " stream)
           (when (lisp:zerop cnt)
         (princ "..." stream)
         (return))
           (display var stream)
           (lisp:decf cnt)))))

(defmethod 0? ((element t)) nil)
(defmethod 1? ((element t)) nil)

;; Ordering functions for general expressions

;; Some operators may choose to ignore various parameters here.
(defun ge-equal (x y)
  (cond ((number? x) (and (number? y) (= x y)))
    ((ge-variable? x) (eql x y))
    ((ge-variable? y) nil)
    ((and (eql (first x) (first y)))
     (let ((equal-func (get (first x) :ge-equal)))
       (if equal-func
           (%funcall equal-func x y)
           (ge-lequal (rest x) (rest y)))))))

(defun ge-lequal (x y)
  (loop
    (when (and (null x) (null y))
      (return-from ge-lequal t))
    (when (or (null x) (null y)
          (not (ge-equal (first x) (first y))))
      (return-from ge-lequal nil))
    (pop x) (pop y)))

(defun ge-lgreat (x y)
  (loop
    (cond ((null x)
       (return nil))
      ((null y)
       (return t))
      ((ge-equal (first x) (first y)))
      ((ge-great (first x) (first y))
       (return t))
      (t (return nil)))
    (pop x) (pop y)))

(defun ge-great (x y)
  (cond ((number? x)
     (and (number? y) (> x y)))
    ((number? y) t)
    ((ge-variable? x)
     (ge-variable-great x y))
    ((ge-variable? y)
     (not (ge-variable-great y x)))
    ((eql (first x) (first y))
     (cond ((get (first x) :ge-great)
        (%funcall (get (first x) :ge-great) x y))
           (t (ge-lgreat (rest x) (rest y)))))
    (t (string-lessp (string (first x)) (string (first y))))))

;; x is assumed to be a variable
(defun ge-variable-great (x y)
  (cond ((ge-variable? y)
     (string-greaterp (getf (rest x) :string) (getf (rest y) :string)))
    ((or (ge-plus? y)
         (ge-times? y))
     (loop for w in (rest y)
           unless (ge-great x w)
         do (return nil)
           finally (return t)))
    (t nil)))

(defun real? (x)
  (or (and (numberp x) (not (lisp:complexp x)))
      (bigfloatp x)))

(defmethod minus? ((x t))
  nil)

(defmethod plus? ((x t))
  (and (not (0? x)) (not (minus? x))))

;; For compatibility with Common Lisp
(defun minusp (x) (minus? x))
(defun plusp (x) (plus? x))
(defun zerop (x) (0? x))

(defun ge-minus? (x)
  (cond ((and (number? x) (real? x)) (minus? x))
    ((ge-times? x)
     (and (real? (second x))
          (minus? (second x))))
    (t nil)))

(defmacro def-ge-operator (op &rest args)
  (macrolet ((decode-operator (keyword string &body body)
           `(when (getf args ,keyword)
          (let* ((fun-name (intern (format nil ,string op)))
             (function (getf args ,keyword))
             arglist body)
            (when (eql (first function) 'function)
              (setq function (second function)))
            (unless (eql (first function) 'lambda)
              (error "Invalid function supplied for ~S operator: ~A"
                 ,keyword op))
            (setq arglist (second function)
              body (rest (rest function)))
            ,@body))))
    (let ((pred-name (intern (format nil "GE-~A?" op))))
      `(progn
     (setf (get ',op :ge-operator) ',op)
     (defsubst ,pred-name (x)
       (and (not (atom x)) (eql (first x) ',op)))
     ,@(when (getf args :alias)
         `((setf (get ',(getf args :alias) :ge-operator) ',op)))
     ,@(when (getf args :num-arguments)
         `((setf (get ',op :num-arguments) ,(getf args :num-arguments))))
     ,@(decode-operator :coerce "GE-~A-COERCE"
         (unless (lisp::= 2 (length arglist))
           (error "Wrong number of arguments for COERCE function: ~S"
              op))
         `((defun ,fun-name ,arglist ,@body)
           (setf (get ',op :ge-coerce) ',fun-name)))
     ,@(decode-operator :equal "GE-~A-EQUAL"
         (unless (lisp::= 2 (length arglist))
           (error "Wrong number of arguments for EQUAL function: ~S"
              op))
         `((defun ,fun-name ,arglist ,@body)
           (setf (get ',op :ge-equal) ',fun-name)))
     ,@(decode-operator :great "GE-~A-GREAT"
         (unless (lisp::= 2 (length arglist))
           (error "Wrong number of arguments for GREAT function: ~S"
              op))
         `((defun ,fun-name ,arglist ,@body)
           (setf (get ',op :ge-great) ',fun-name)))
     ,@(decode-operator :display "DISPLAY-~A"
         (unless (lisp::= 2 (length arglist))
           (error "Wrong number of arguments for DISPLAY function: ~S"
              op))
         `((setf (get ',op 'display-function) ',fun-name)
           (defun ,fun-name ,arglist ,@body (values))))
     ,@(decode-operator :simplify "SIMPLIFY-~A"
                `((setf (get ',op 'simplify-function) ',fun-name)
                  (defun ,fun-name ,arglist ,@body)))))))

(def-ge-operator PLUS
  :alias +
  :display (lambda (expr stream)
         (display (second expr) stream)
         (loop for x in (rest (rest expr))
           do (cond ((and (number? x) (real? x))
                 (if (plus? x)
                 (format stream " + ~S" x)
                 (format stream " - ~S" (minus x))))
                ((ge-minus? x)
                 (princ " - " stream)
                 (display (simplify `(times ,(minus (second x))
                            ,@(rest (rest x))))))
                (t (princ " + " stream)
                   (display x stream))))))

(def-ge-operator TIMES
  :alias *
  :display (lambda (expr stream)
         (safe-display (second  expr) stream)
         (loop for x in (rest (rest expr))
           do (princ " " stream)
              (safe-display x stream))))

(def-ge-operator EXPT
  :num-arguments 2
  :display (lambda (expr stream)
         (safe-display (second expr) stream)
         (princ "^" stream)
         (safe-display (third expr) stream)))

(def-ge-operator COS :num-arguments 1)
(def-ge-operator SIN :num-arguments 1)
(def-ge-operator TAN :num-arguments 1)
(def-ge-operator ACOS :num-arguments 1)
(def-ge-operator ASIN :num-arguments 1)
(def-ge-operator ATAN :num-arguments 1)
(def-ge-operator COSH :num-arguments 1)
(def-ge-operator SINH :num-arguments 1)
(def-ge-operator TANH :num-arguments 1)
(def-ge-operator ACOSH :num-arguments 1)
(def-ge-operator ASINH :num-arguments 1)
(def-ge-operator ATANH :num-arguments 1)

(def-ge-operator DERIV
  :num-arguments 2
  :coerce (lambda (x domain)
        (let ((derivs (if (or (symbolp (third x))
                  (ge-variable? (third x))
                  (rest (rest (rest x))))
                  (rest (rest x))
                  (third x))))
          `(deriv ,(coerce (second x) domain)
              ,(loop for w in derivs
                 collect (cond ((or (atom w) (ge-variable? w))
                        (list (coerce w domain) 1))
                       (t (list (coerce (first w) domain)
                            (coerce (second w) domain))))))))
  :display (lambda (expr stream)
         (princ "D{" stream)
         (display (second expr) stream)
         (let ((derivs (third expr)))
           (cond ((numberp derivs)
              (format stream ", ~D}" derivs))
             ((and (null (rest derivs))
               (eql 1 (second (first derivs))))
              (princ ", " stream)
              (display (first (first derivs)) stream)
              (princ "}" stream))
             (t (princ ", {" stream)
            (loop for (var order) in derivs
                  and first? = t then nil do
                (unless first?
                  (princ ", " stream))
                (cond ((eql order 1)
                       (display var stream))
                      (t (display var stream)
                     (format stream "^~D" order))))
            (princ "}}" stream)))))
  :equal (lambda (x y)
       (let ((x-vars (third x))
         (y-vars (third y)))
         (and (ge-equal (second x) (second y))
          (equal (length x-vars) (length y-vars))
          (loop for (x-var x-order) in x-vars
            and (y-var y-order) in y-vars
            unless (and (ge-equal x-var y-var)
                    (ge-equal x-order y-order))
              do (return nil)
            finally (return t)))))
  :great (lambda (x y)
       (let ((x-vars (third x))
         (y-vars (third y)))
         (cond ((ge-great (second x) (second y)) t)
           ((ge-great (second y) (second x)) nil)
           (t (loop for (x-var x-order) in x-vars
                and (y-var y-order) in y-vars
                do (cond ((ge-great x-var y-var) (return t))
                     ((ge-equal x-var y-var)
                      (cond ((ge-great x-order y-order)
                         (return t))
                        ((ge-great y-order x-order)
                         (return nil))))
                     (t (return nil)))))))))

(def-ge-operator DERIVATION
  :num-arguments 2
  :display (lambda (expr stream)
         (let ((base (second expr))
           (order (third expr)))
           (cond ((< order 3)
              (display base stream)
              (cond ((= order 0))
                ((= order 1) (princ #\' stream))
                ((= order 2) (princ #\" stream))
                (t (format stream "(~D)" order))))
             (t (princ "d{" stream)
            (display base stream)
            (format stream ", ~D}" order)))))
  :equal (lambda (x y)
       (and (ge-equal (second x) (second y))
        (ge-equal (third x) (third y))))
  :great (lambda (x y)
       (cond ((ge-great (second x) (second y)) t)
         ((ge-great (second y) (second x)) nil)
         (t (ge-great (third x) (third y))))))

;; Simplify

(defmethod simplify ((x symbol))
  (coerce x *general*))

(defmethod simplify ((x number))
  x)

;; This works by converting the sum into a list of dotted pairs.  The
;; first element of the list is a number, while the second is a list
;; of product terms.  This makes combining new elements quite easy.
;; After the combination, everything is converted back to the standard
;; representation.

(defmacro merge-terms-in-sum (terms &body body)
  `(let ((,terms (list nil)))
     (labels ((add-term (base order)
        (loop with terms = ,terms do
          (cond ((or (null (rest terms))
                 (ge-lgreat base (rest (second terms))))
             (push (cons order base) (rest terms))
             (return t))
            ((ge-lequal base (rest (second terms)))
             (incf (first (second terms)) order)
             (when (0? (first (second terms)))
               (setf (rest terms) (rest (rest terms))))
             (return t)))
          (pop terms))))
       ,@body)))

(defmethod simplify ((x list))
  (let ((key (first x))
    simplifier)
    (cond ((eql key 'variable) x)
      ((setq simplifier (get key 'simplify-function))
       (%funcall simplifier x))
      (t x))))

(setf (get 'plus 'simplify-function) 'simplify-plus)

(defun simplify-plus (x)
  (merge-terms-in-sum terms
    (let ((const 0))
      (labels ((loop-over-terms (terms)
         (loop for term in terms
               do (setq term (simplify term))
              (cond ((number? term)
                 (setq const (+ const term)))
                ((ge-plus? term)
                 (loop-over-terms (rest term)))
                ((ge-times? term)
                 (cond ((number? (second term))
                    (add-term (rest (rest term))
                          (second term)))
                       (t (add-term (rest term) 1))))
                (t (add-term (list term) 1))))))
    (loop-over-terms (rest x))
    (setq terms (loop for (c . term-l) in (rest terms)
              collect
              (if (or (eql c 1) (eql c 1.0))
                  (if (null (rest term-l))
                  (first term-l)
                  `(times ,@term-l))
                  `(times ,c ,@term-l))))
    (cond ((not (0? const))
           (if (null terms) const
           `(plus ,const ,@terms)))
          ((null terms)
           0)
          ((null (rest terms))
           (first terms))
          (t `(plus ,@terms)))))))


(setf (get 'times 'simplify-function) 'simplify-times)

(defun simplify-times (x)
  (merge-terms-in-sum terms
    (let ((const 1))
      (labels ((loop-over-terms (terms)
         (loop for term in terms
               do (setq term (simplify term))
              (cond ((number? term)
                 (when (0? term)
                   (return-from simplify-times 0))
                 (setq const (lisp::* const term)))
                ((ge-times? term)
                 (loop-over-terms (rest term)))
                ((ge-expt? term)
                 (cond ((number? (third term))
                    (add-term (list (second term)) (third term)))
                       (t (add-term (list (second term)) 1))))
                (t (add-term (list term) 1))))))
    (loop-over-terms (rest x))
    (setq terms (loop for (exp base) in (rest terms)
              collect
              (if (eql exp 1) base
                  `(expt ,base ,exp))))
    (cond ((not (or (eql const 1) (eql const 1.0)))
           (if (null terms) const
           `(times ,const ,@terms)))
          ((null terms) 1)
          ((null (rest terms))
           (first terms))
          (t `(times ,@terms)))))))


(setf (get 'expt 'simplify) 'simplify-expt)

(defun simplify-expt (x)
  (let ((exp (simplify (third x))))
    (cond ((0? exp) 1)
      ((eql 1 exp) (simplify (second x)))
      (t `(expt ,(simplify (second x)) ,exp)))))

(setf (get 'log 'simplify-function) 'simplify-log)
(defun simplify-log (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp::floatp exp) (lisp:log exp))
      ((ge-expt? exp)
       (simplify
        `(times ,(third exp) (log ,(second exp)))))
      (t `(log ,exp)))))

(setf (get 'sin 'simplify-function) 'simplify-sin)
(defun simplify-sin (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp::floatp exp) (lisp:sin exp))
      ((and (number? exp) (0? exp))
       0)
      ((ge-minus? exp)
       `(times -1
           (sin ,(simplify `(times ,(minus (second exp))
                       ,@(rest (rest exp)))))))
      (t `(sin ,exp)))))

(setf (get 'cos 'simplify-function) 'simplify-cos)
(defun simplify-cos (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp::floatp exp) (lisp:cos exp))
      ((and (number? exp) (0? exp)) 1)
      ((ge-minus? exp)
       `(cos ,(simplify `(times ,(minus (second exp))
                    ,@(rest (rest exp))))))
      (t `(cos ,exp)))))

(setf (get 'tan 'simplify-function) 'simplify-tan)
(defun simplify-tan (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp::floatp exp) (lisp:tan exp))
      ((and (number? exp) (0? exp))
       0)
      ((ge-minus? exp)
       `(times -1
           (tan ,(simplify `(times ,(minus (second exp))
                       ,@(rest (rest exp)))))))
      (t `(tan ,exp)))))

(setf (get 'asin 'simplify-function) 'simplify-asin)
(defun simplify-asin (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp:floatp exp) (lisp:asin exp))
      ((and (number? exp) (0? exp))
       0)
      ((ge-minus? exp)
       `(times -1
           (asin ,(simplify `(times ,(minus (second exp))
                        ,@(rest (rest exp)))))))
      (t `(asin ,exp)))))

(setf (get 'acos 'simplify-function) 'simplify-acos)
(defun simplify-acos (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp::floatp exp) (lisp:acos exp))
      (t `(acos ,exp)))))

(setf (get 'atan 'simplify-function) 'simplify-atan)
(defun simplify-atan (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp::floatp exp) (lisp:atan exp))
      (t `(atan ,exp)))))

(setf (get 'sinh 'simplify-function) 'simplify-sinh)
(defun simplify-sinh (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp::floatp exp) (lisp:sinh exp))
      ((and (number? exp) (0? exp))
       0)
      ((ge-minus? exp)
       `(times -1
           (sinh ,(simplify `(times ,(minus (second exp))
                        ,@(rest (rest exp)))))))
      (t `(sinh ,exp)))))

(setf (get 'cosh 'simplify-function) 'simplify-cosh)
(defun simplify-cosh (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp::floatp exp) (lisp:cosh exp))
      ((and (number? exp) (0? exp)) 1)
      ((ge-minus? exp)
       `(cosh ,(simplify `(times ,(minus (second exp))
                     ,@(rest (rest exp))))))
      (t `(cosh ,exp)))))

(setf (get 'tanh 'simplify-function) 'simplify-tanh)
(defun simplify-tanh (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp::floatp exp) (lisp:tanh exp))
      ((and (number? exp) (0? exp))
       0)
      ((ge-minus? exp)
       `(times -1
           (tanh ,(simplify `(times ,(minus (second exp))
                        ,@(rest (rest exp)))))))
      (t `(tanh ,exp)))))

(setf (get 'asinh 'simplify-function) 'simplify-asinh)
(defun simplify-asinh (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp:floatp exp) (lisp:asinh exp))
      ((and (number? exp) (0? exp))
       0)
      ((ge-minus? exp)
       `(times -1
           (asinh ,(simplify `(times ,(minus (second exp))
                         ,@(rest (rest exp)))))))
      (t `(asinh ,exp)))))

(setf (get 'acosh 'simplify-function) 'simplify-acosh)
(defun simplify-acosh (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp::floatp exp) (lisp:acosh exp))
      (t `(acosh ,exp)))))

(setf (get 'atanh 'simplify-function) 'simplify-atanh)
(defun simplify-atanh (x)
  (let ((exp (simplify (second x))))
    (cond ((lisp::floatp exp) (lisp:atanh exp))
      (t `(atanh ,exp)))))

(setf (get 'deriv 'simplify) 'simplify-deriv)
(defun simplify-deriv (x)
  (let ((arg (simplify (second x))))
    (merge-terms-in-sum derivs
      (loop for (var order) in (third x) do
    (add-term (list var) order))
      (when (ge-deriv? arg)
    (loop for (var order) in (third arg) do
      (add-term (list var) order))
    (setq arg (second arg)))
      `(deriv ,arg
          ;; Really don't need dot below...
          ,(loop for (order base) in (rest derivs)
             collect (list base order))))))

;; The following transforming characterizes one of the very common
;; control structures used in symbolic computation.  It needs  great
;; deal of refinement still.
(defmacro ge-transform ((transform form) forms &body body)
  (let (temp)
    `(labels
     ((,transform (,form)
        (cond ((ge-variable? ,form)
           ,@(if (null (setq temp (assoc :variable forms)))
             `((error "Don't know how to transform ~S" ,form))
             (rest temp)))
          ((ge-plus? ,form)
           ,@(if (null (setq temp (assoc :plus forms)))
             `((loop with ans = (,transform (second ,form))
                   for x in (rest (rest ,form))
                   do (setq ans (+ ans (,transform x)))
                   finally (return ans)))
             (rest temp)))
          ((ge-times? ,form)
           ,@(if (null (setq temp (assoc :times forms)))
             `((loop with ans = (,transform (second ,form))
                   for x in (rest (rest ,form))
                   do (setq ans (* ans (,transform x)))
                   finally (return ans)))
             (rest temp)))
          ((ge-expt? ,form)
           ,@(if (null (setq temp (assoc :expt forms)))
             `((expt (,transform (second ,form)) (third ,form)))
             (rest temp)))
          ,@(loop for (pred . exprs) in forms
              unless (member pred '(:variable :plus :times :expt
                        :otherwise))
                collect `(,pred ,@ exprs))
          ,@(when (setq temp (assoc :otherwise forms))
              `((t ,@(rest temp)))))))
       ,@body)))

(defmethod plus ((x (or list symbol integer number))
         (y (or list symbol)))
  (simplify `(plus ,(coerce x *general*) ,(coerce y *general*))))

(defmethod plus ((x (or list symbol)) (y (or integer number)))
  (simplify `(plus ,(coerce x *general*) ,(coerce y *general*))))

(defmethod difference ((x (or list symbol integer number))
               (y (or list symbol)))
  (simplify `(plus ,(coerce x *general*) (times -1 ,(coerce y *general*)))))

(defmethod difference ((x (or list symbol)) (y (or integer number)))
  (simplify `(plus ,(coerce x *general*) (times -1 ,(coerce y *general*)))))

(defmethod minus ((x (or symbol list)))
  (simplify `(times -1 ,(coerce x *general*))))

(defmethod times ((x (or list symbol integer number))
          (y (or list symbol)))
  (simplify `(times ,(coerce x *general*) ,(coerce y *general*))))

(defmethod times ((x (or list symbol)) (y (or integer number)))
  (simplify `(times ,(coerce x *general*) ,(coerce y *general*))))

(defmethod expt ((x (or list symbol integer number))
          (y (or list symbol)))
  (simplify `(expt ,(coerce x *general*) ,(coerce y *general*))))

(defmethod expt ((x (or list symbol)) (y (or integer number)))
  (simplify `(expt ,(coerce x *general*) ,(coerce y *general*))))

(defmethod sin ((x (or symbol list)))
  (simplify `(sin ,(coerce x *general*))))

(defmethod cos ((x (or symbol list)))
  (simplify `(cos ,(coerce x *general*))))

(defmethod tan ((x (or symbol list)))
  (simplify `(tan ,(coerce x *general*))))

(defmethod log ((x (or symbol list)))
  (simplify `(log ,(coerce x *general*))))

(defmethod deriv ((exp (or number symbol list)) &rest vars)
  (setq exp (coerce exp *general*))
  (loop for v in vars
    do (setq exp (ge-deriv exp (coerce v *general*))))
  exp)

(defmacro declare-derivative  (func args var &body body)
  `(setf (get ',func 'derivative-function)
    (lambda (.arg. ,var)
      (let ,args
        ,@(loop for arg in args collect
          `(setq ,arg (pop .arg.)))
        (simplify (progn ,@body))))))

(declare-derivative sin (x) var
  (* (deriv x var) (cos x)))

(declare-derivative cos (x) var
  (* (- (deriv x var)) (sin x)))

(declare-derivative log (x) var
  (* (deriv x var) (expt x -1)))

(defun ge-deriv (exp var)
  (cond ((number? exp) 0)
    ((ge-variable? exp)
     (cond ((ge-equal exp var) 1)
           ((depends-on? exp var)
        `(deriv ,exp ((,var 1))))
           (t 0)))
    ((eql (first exp) 'plus)
     (simplify
      `(plus ,@(loop for x in (rest exp)
             collect (ge-deriv x var)))))
    ((eql (first exp) 'times)
     (simplify
      `(plus ,@(loop for x in (rest exp)
             collect
              (simplify
                `(times ,(ge-deriv x var)
                    ,@(remove x (rest exp))))))))
    ((eql (first exp) 'expt)
     (let ((base (second exp))
           (power (third exp)))
     (cond ((depends-on? power var)
        (error "Not implemented yet"))
           ((and (number? power) (= power 2))
        (* 2 base (ge-deriv base var)))
           (t (* power (expt base (- power 1)))))))
    ((eql (first exp) 'deriv)
     (labels ((deriv (l)
            (cond ((null l) nil)
              ((ge-equal var (first (first l)))
               (cons (list var (1+ (second (first l))))
                 (rest l)))
              (t (cons (first l)
                   (deriv (second l)))))))
       `(deriv ,(second exp) ,(deriv (third exp)))))
    (t (let ((func (get (first exp) 'derivative-function)))
         (if func
         (%funcall func (rest exp) var)
         (error "Don't know how to take derivative of ~S" exp))))))

(defmacro map-over-expressions (exp (comps type . options) &body body)
  (if (null options)
      `(%map-over-expressions ,exp (lambda (,comps ,type) ,@body))
      `(apply #'%map-over-expressions ,exp (lambda (,comps ,type) ,@body)
          options)))

(defmethod %map-over-expressions ((exp (or symbol list)) func &rest options)
  (declare (ignore options))
  (labels ((moe (exp)
         (cond ((number? exp)
            (prog1
              (funcall func exp :number)))
           ((ge-variable? exp)
            (prog1
              (funcall func exp :variable)))
           ((ge-plus? exp)
            (multiple-value-bind (value recurse?)
            (funcall func exp :plus)
              (when recurse?
            (loop for e in (rest exp) do (moe e)))
              value))
           ((ge-times? exp)
            (multiple-value-bind (value recurse?)
            (funcall func exp :times)
              (when recurse?
            (loop for e in (rest exp) do (moe e)))
              value))
           ((ge-expt? exp)
            (multiple-value-bind (value recurse?)
            (funcall func exp :expt)
              (when recurse?
            (moe (second exp))
            (moe (third exp)))
              value))
           (t (funcall func exp (first exp))))))
    (moe exp)))