misc-code/derive2.lisp

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

(defpackage #:derive2
  (:use #:cl)
  (:export :derive
           :csc
           :sec
           :define-equation-functions
           :take-derivative))

(in-package #:derive2)

;;; "derive2" goes here.

(defvar *rules* '())

(defun generate-match-expression (on arity &optional (type '=))
  (declare (symbol on type)
           (integer arity))
  (case type
    (=
     `(and (eq function ',on)
         (= arg-count ,arity)))
    (>
     `(and (eq function ',on)
         (> arg-count ,arity)))
    (>=
     `(and (eq function ',on)
         (>= arg-count ,arity)))))

(defmacro def-expansion (name (on arity &optional type) (&rest arguments) &body expansion)
  (declare (ignorable name on arity type arguments expansion))
  (let ((match-expression (if type
                              (generate-match-expression on arity type)
                              (generate-match-expression on arity))))
    `(progn
       (push (list ',name
                   (lambda (function &rest arguments &aux (arg-count (length arguments)))
                     ,match-expression)
                   (lambda (,@arguments)
                     ,@expansion))
             *rules*)
       ',name)))

(defun get-expansion (expression)
  (first
   (remove-if #'null
              (map 'list
                #'(lambda (nte)
                    (let ((test (second nte))
                          (expander (third nte)))
                      (if (apply test expression)
                          expander
                          nil)))
                *rules*))))

(defun derive (function)
  (declare (cons function))
  (let ((op (first function)))
    (cond
      ((numberp op)
       0)
      ((and (symbolp op)
          (= 1 (length function)))
       1)
      (t
       (let ((expansion-function (get-expansion function)))
         (if (functionp expansion-function)
             (apply expansion-function (rest function))
             (error "Undefined expansion: ~a" op)))))))

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

(def-expansion mult/2 (* 2) (first second)
  (cond
    ((numberp first)
     `(* ,first ,(derive (if (listp second) second (list second)))))
    ((numberp second)
     `(* ,second ,(derive (if (listp first) first (list second)))))
    (t
     `(+ (* ,first ,(derive (if (listp second) second (list second))))
         (* ,second ,(derive (if (listp first) first (list first))))))))

(def-expansion mult/3+ (* 3 >=) (first &rest rest)
  (derive `(* ,first ,(cons '* rest))))

(def-expansion div/2 (/ 2) (numerator denominator)
  `(/ (- (* ,numerator ,(derive denominator))
         (* ,denominator ,(derive numerator)))
      (expt ,denominator 2)))

(def-expansion plus/2+ (+ 2 >=) (&rest clauses)
  `(+ ,@(map 'list #'(lambda (clause)
                       (if (listp clause)
                           (derive clause)
                           (derive (list clause))))
             clauses)))

(def-expansion minus/2+ (- 2 >=) (&rest clauses)
  `(- ,@(map 'list #'(lambda (clause)
                       (if (listp clause)
                           (derive clause)
                           (derive (list clause))))
             clauses)))

(def-expansion exp/1 (exp 1) (expression)
  (if (listp expression)
      `(* (expt ,expression) ,(derive expression))
      (if (numberp expression)
          0
          `(expt ,expression))))

(def-expansion expt/2 (expt 2) (base exponent)
  (if (listp base)
      `(* ,exponent (expt ,base (1- ,exponent)) ,(derive base))
      `(* ,exponent (expt ,base (1- ,exponent)))))

(def-expansion log/1 (log 1) (expression)
  `(/ ,(derive (if (listp expression) expression (list expression))) ,expression))

(def-expansion log/2 (log 2) (number base)
  (declare (ignorable number base))
  `(/ (derive (cons 'log number)) (log ,base)))

(def-expansion sin/1 (sin 1) (arg)
  `(* (cos ,arg) ,(derive arg)))

(def-expansion cos/1 (cos 1) (arg)
  `(* (- (sin ,arg)) ,(derive arg)))

(def-expansion tan/1 (tan 1) (arg)
  `(* (expt (sec ,arg) 2) ,(derive arg)))

(def-expansion csc/1 (csc 1) (arg)
  `(* (- (csc ,arg)) (cot ,arg) ,(derive arg)))

(def-expansion sec/1 (sec 1) (arg)
  `(* (sec ,arg) (tan ,arg) ,(derive arg)))

(def-expansion cot/1 (cot 1) (arg)
  `(* (- (expt (csc ,arg) 2)) ,(derive arg)))

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