misc-code/derive.lisp

;;;; derive.lisp
;;;;
;;;; Copyright (c) 2015 Samuel W. Flint <swflint@flintfam.org>

#+quicklisp (ql:quickload :uiop)

(defpackage #:derive
  (:use #:cl)
  (:export :derive
           :csc
           :sec
           :define-equation-functions
           :take-derivative)
  #-(or ccl sbcl) (:import-from #:uiop
                               #:quit))

(in-package #:derive)

;;; "derive" goes here.

(defun derive (equation)
  "derive -- (derive equation)
Derives an equation using the normal rules of differentiation."
  (declare (cons equation))
  (let ((op (first equation)))
    (cond
      ((member op '(sin cos tan csc sec cot))
       (chain equation))
      ((equal op 'expt)
       (power (rest equation)))
      ((equal op '*)
       (mult (rest equation)))
      ((equal op '/)
       (div (rest equation)))
      ((or (equal op '+)
          (equal op '-))
       (apply #'plus/minus op (rest equation)))
      ((numberp op)
       0)
      (t
       1))))

(defun plus/minus (op &rest args)
  "plus/minus -- (plus/minus op &rest args)
Derive for plus/minus"
  (declare (symbol op)
           (cons args))
  (let ((out (list op)))
    (loop for arg in args
       do (let ((derivative (derive (if (not (listp arg)) (list arg) arg))))
            (if (eq 0 derivative)
                nil
                (push derivative out))))
    (if (equal (list op) out)
        nil
        (reverse out))))

(defun mult (equation)
  "mult -- (mult equation)
Derive multiplication"
  (if (= (length equation) 2)
      (if (numberp (first equation))
          `(* ,(first equation) ,(derive (if (not (listp (second equation))) (list (second equation)) (second equation))))
          (if (numberp (second equation))
              `(* ,(second equation) ,(derive (if (not (listp (first equation))) (list (first equation)) (first equation))))
              `(+ (* ,(first equation) ,(derive (second equation)))
                  (* ,(second equation) ,(derive (first equation))))))
      (mult (list (first equation) (mult (rest equation))))))

(defun div (equation)
  "div -- (div equation)
Derive using quotient rule"
  (let ((numerator (nth 0 equation))
        (denominator (nth 1 equation)))
    `(/ (- (* ,numerator ,(derive denominator))
           (* ,denominator ,(derive numerator)))
        (expt ,denominator 2))))

(defun chain (equation)
  "chain -- (chain equation)
Apply the chain rule to the equation"
  (declare (cons equation))
  (let ((op (first equation))
        (arg (second equation)))
    (case op
      (sin
       `(* (cos ,arg) ,(derive arg)))
      (cos
       `(* (- (sin ,arg)) ,(derive arg)))
      (tan
       `(* (expt (sec ,arg) 2) ,(derive arg)))
      (csc
       `(* (- (csc ,arg)) (cot ,arg) ,(derive arg)))
      (sec
       `(* (sec ,arg) (tan ,arg) ,(derive arg)))
      (cot
       `(* (- (expt (csc ,arg) 2)) ,(derive arg))))))

(defun power (eq)
  "power -- (power rest)
Apply the Power Rule"
  (declare (cons eq))
  (let ((equation (nth 0 eq))
        (power (nth 1 eq)))
    (if (listp equation)
        `(* ,power (expt ,equation ,(1- power)) ,(derive equation))
        `(* ,power (expt ,equation ,(1- power))))))

(defun csc (x)
  "csc -- (csc x)
Calculate the cosecant of x"
  (/ (sin x)))

(defun sec (x)
  "sec -- (sec x)
Calculate the secant of x"
  (/ (cos x)))

(defun repl ()
  (format t "Welcome to the automatic derivative calculator. Type quit to exit.~&~&> ")
  (loop (progn (let ((in (read)))
                 (cond
                   ((eq in 'quit)
                    #-(or ccl sbcl) (quit)
                    #+sbcl (sb-ext:exit)
                    #+ccl (ccl:quit))
                   ((eq in 'trace)
                    (trace derive plus/minus mult div chain power))
                   ((eq in 'untrace)
                    (untrace derive plus/minus mult div chain power))
                   ((eq in nil))
                   ((listp in)
                    (format t "~%~a~%" (derive in)))))
               (format t "~&> "))))

#+sbcl (progn
         (defun save-exec ()
           #+lparallel (lparallel:end-kernel)
           (sb-ext:save-lisp-and-die "derive"
                                     :toplevel #'repl
                                     :executable t
                                     :purify t
                                     :save-runtime-options t))
         (export 'save-exec))

#+ccl (progn
        (defun save-exec ()
          #+lparallel (lparallel:end-kernel)
          (ccl:save-application "derive"
                                :toplevel-function #'repl
                                :prepend-kernel t
                                :purify t))
        (export 'save-exec))

(defmacro define-equation-functions (name variable equation)
  (let ((derivative-name
         (intern (string-upcase (format nil "d/d~a-~a" variable name))))
        (derivative (derive equation)))
    `(progn
       (defun ,name (,variable)
         ,equation)
       (defun ,derivative-name (,variable)
         ,derivative))))

(defmacro take-derivative (equation)
  (let ((derivative (derive equation)))
    `',derivative))

;;; End derive