derive.lisp 3.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129
  1. ;;;; derive.lisp
  2. ;;;;
  3. ;;;; Copyright (c) 2015 Samuel W. Flint <swflint@flintfam.org>
  4. (defpackage #:derive
  5. (:use #:cl)
  6. (:export :derive
  7. :csc
  8. :sec
  9. :define-equation-functions
  10. :take-derivative))
  11. (in-package #:derive)
  12. ;;; "derive" goes here.
  13. (defun derive (equation)
  14. "derive -- (derive equation)
  15. Derives an equation using the normal rules of differentiation."
  16. (declare (cons equation))
  17. (let ((op (first equation)))
  18. (cond
  19. ((member op '(sin cos tan csc sec cot))
  20. (chain equation))
  21. ((equal op 'expt)
  22. (power (rest equation)))
  23. ((equal op '*)
  24. (mult (rest equation)))
  25. ((equal op '/)
  26. (div (rest equation)))
  27. ((or (equal op '+)
  28. (equal op '-))
  29. (apply #'plus/minus op (rest equation)))
  30. ((numberp op)
  31. 0)
  32. (t
  33. 1))))
  34. (defun plus/minus (op &rest args)
  35. "plus/minus -- (plus/minus op &rest args)
  36. Derive for plus/minus"
  37. (declare (symbol op)
  38. (cons args))
  39. (let ((out (list op)))
  40. (loop for arg in args
  41. do (let ((derivative (derive (if (not (listp arg)) (list arg) arg))))
  42. (if (eq 0 derivative)
  43. nil
  44. (push derivative out))))
  45. (if (equal (list op) out)
  46. nil
  47. (reverse out))))
  48. (defun mult (equation)
  49. "mult -- (mult equation)
  50. Derive multiplication"
  51. (if (= (length equation) 2)
  52. (if (numberp (first equation))
  53. `(* ,(first equation) ,(derive (if (not (listp (second equation))) (list (second equation)) (second equation))))
  54. (if (numberp (second equation))
  55. `(* ,(second equation) ,(derive (if (not (listp (first equation))) (list (first equation)) (first equation))))
  56. `(+ (* ,(first equation) ,(derive (second equation)))
  57. (* ,(second equation) ,(derive (first equation))))))
  58. (mult (list (first equation) (mult (rest equation))))))
  59. (defun div (equation)
  60. "div -- (div equation)
  61. Derive using quotient rule"
  62. (let ((numerator (nth 0 equation))
  63. (denominator (nth 1 equation)))
  64. `(/ (- (* ,numerator ,(derive denominator))
  65. (* ,denominator ,(derive numerator)))
  66. (expt ,denominator 2))))
  67. (defun chain (equation)
  68. "chain -- (chain equation)
  69. Apply the chain rule to the equation"
  70. (declare (cons equation))
  71. (let ((op (first equation))
  72. (arg (second equation)))
  73. (case op
  74. (sin
  75. `(* (cos ,arg) ,(derive arg)))
  76. (cos
  77. `(* (- (sin ,arg)) ,(derive arg)))
  78. (tan
  79. `(* (expt (sec ,arg) 2) ,(derive arg)))
  80. (csc
  81. `(* (- (csc ,arg)) (cot ,arg) ,(derive arg)))
  82. (sec
  83. `(* (sec ,arg) (tan ,arg) ,(derive arg)))
  84. (cot
  85. `(* (- (expt (csc ,arg) 2)) ,(derive arg))))))
  86. (defun power (eq)
  87. "power -- (power rest)
  88. Apply the Power Rule"
  89. (declare (cons eq))
  90. (let ((equation (nth 0 eq))
  91. (power (nth 1 eq)))
  92. (if (listp equation)
  93. `(* ,power (expt ,equation (1- ,power)) ,(derive equation))
  94. `(* ,power (expt ,equation (1- ,power))))))
  95. (defun csc (x)
  96. "csc -- (csc x)
  97. Calculate the cosecant of x"
  98. (/ (sin x)))
  99. (defun sec (x)
  100. "sec -- (sec x)
  101. Calculate the secant of x"
  102. (/ (cos x)))
  103. (defmacro define-equation-functions (name variable equation)
  104. (let ((derivative-name
  105. (intern (string-upcase (format nil "d/d~a-~a" variable name))))
  106. (derivative (derive equation)))
  107. `(progn
  108. (defun ,name (,variable)
  109. ,equation)
  110. (defun ,derivative-name (,variable)
  111. ,derivative))))
  112. (defmacro take-derivative (equation)
  113. (let ((derivative (derive equation)))
  114. `',derivative))
  115. ;;; End derive