misc-code/derive2.lisp

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

(defpackage #:derive2
  (:use #:cl)
  (:export :derive
           :csc
           :sec))

(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 derive (function)
  (declare (cons function))
  (let ((op (first function)))
    (cond
      ((numberp op)
       0)
      ((and (symbolp op)
          (= 1 (length function)))
       1)
      (t
       (let ((expansion-function))
         (loop for (name test expander) in *rules*
            do (if (apply test function)
                   (setf expansion-function expander)))
         (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 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))

;;; End derive2