derive2.lisp 4.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164
  1. ;;;; derive2.lisp
  2. ;;;;
  3. ;;;; Copyright (c) 2015 Samuel W. Flint <swflint@flintfam.org>
  4. (defpackage #:derive2
  5. (:use #:cl)
  6. (:export :derive
  7. :csc
  8. :sec
  9. :define-equation-functions
  10. :take-derivative))
  11. (in-package #:derive2)
  12. ;;; "derive2" goes here.
  13. (defvar *rules* '())
  14. (defun generate-match-expression (on arity &optional (type '=))
  15. (declare (symbol on type)
  16. (integer arity))
  17. (case type
  18. (=
  19. `(and (eq function ',on)
  20. (= arg-count ,arity)))
  21. (>
  22. `(and (eq function ',on)
  23. (> arg-count ,arity)))
  24. (>=
  25. `(and (eq function ',on)
  26. (>= arg-count ,arity)))))
  27. (defmacro def-expansion (name (on arity &optional type) (&rest arguments) &body expansion)
  28. (declare (ignorable name on arity type arguments expansion))
  29. (let ((match-expression (if type
  30. (generate-match-expression on arity type)
  31. (generate-match-expression on arity))))
  32. `(progn
  33. (push (list ',name
  34. (lambda (function &rest arguments &aux (arg-count (length arguments)))
  35. ,match-expression)
  36. (lambda (,@arguments)
  37. ,@expansion))
  38. *rules*)
  39. ',name)))
  40. (defun get-expansion (expression)
  41. (let (expansion-function)
  42. (loop for (name test expander) in *rules*
  43. do (if (apply test expression)
  44. (setf expansion-function expander)))
  45. expansion-function))
  46. (defun derive (function)
  47. (declare (cons function))
  48. (let ((op (first function)))
  49. (cond
  50. ((numberp op)
  51. 0)
  52. ((and (symbolp op)
  53. (= 1 (length function)))
  54. 1)
  55. (t
  56. (let ((expansion-function (get-expansion function)))
  57. (if (functionp expansion-function)
  58. (apply expansion-function (rest function))
  59. (error "Undefined expansion: ~a" op)))))))
  60. (defun csc (x)
  61. "csc -- (csc x)
  62. Calculate the cosecant of x"
  63. (/ (sin x)))
  64. (defun sec (x)
  65. "sec -- (sec x)
  66. Calculate the secant of x"
  67. (/ (cos x)))
  68. (def-expansion mult/2 (* 2) (first second)
  69. (cond
  70. ((numberp first)
  71. `(* ,first ,(derive (if (listp second) second (list second)))))
  72. ((numberp second)
  73. `(* ,second ,(derive (if (listp first) first (list second)))))
  74. (t
  75. `(+ (* ,first ,(derive (if (listp second) second (list second))))
  76. (* ,second ,(derive (if (listp first) first (list first))))))))
  77. (def-expansion mult/3+ (* 3 >=) (first &rest rest)
  78. (derive `(* ,first ,(cons '* rest))))
  79. (def-expansion div/2 (/ 2) (numerator denominator)
  80. `(/ (- (* ,numerator ,(derive denominator))
  81. (* ,denominator ,(derive numerator)))
  82. (expt ,denominator 2)))
  83. (def-expansion plus/2+ (+ 2 >=) (&rest clauses)
  84. `(+ ,@(map 'list #'(lambda (clause)
  85. (if (listp clause)
  86. (derive clause)
  87. (derive (list clause))))
  88. clauses)))
  89. (def-expansion minus/2+ (- 2 >=) (&rest clauses)
  90. `(- ,@(map 'list #'(lambda (clause)
  91. (if (listp clause)
  92. (derive clause)
  93. (derive (list clause))))
  94. clauses)))
  95. (def-expansion exp/1 (exp 1) (expression)
  96. (if (listp expression)
  97. `(* (expt ,expression) ,(derive expression))
  98. (if (numberp expression)
  99. 0
  100. `(expt ,expression))))
  101. (def-expansion expt/2 (expt 2) (base exponent)
  102. (if (listp base)
  103. `(* ,exponent (expt ,base (1- ,exponent)) ,(derive base))
  104. `(* ,exponent (expt ,base (1- ,exponent)))))
  105. (def-expansion log/1 (log 1) (expression)
  106. `(/ ,(derive (if (listp expression) expression (list expression))) ,expression))
  107. (def-expansion log/2 (log 2) (number base)
  108. (declare (ignorable number base))
  109. `(/ (derive (cons 'log number)) (log ,base)))
  110. (def-expansion sin/1 (sin 1) (arg)
  111. `(* (cos ,arg) ,(derive arg)))
  112. (def-expansion cos/1 (cos 1) (arg)
  113. `(* (- (sin ,arg)) ,(derive arg)))
  114. (def-expansion tan/1 (tan 1) (arg)
  115. `(* (expt (sec ,arg) 2) ,(derive arg)))
  116. (def-expansion csc/1 (csc 1) (arg)
  117. `(* (- (csc ,arg)) (cot ,arg) ,(derive arg)))
  118. (def-expansion sec/1 (sec 1) (arg)
  119. `(* (sec ,arg) (tan ,arg) ,(derive arg)))
  120. (def-expansion cot/1 (cot 1) (arg)
  121. `(* (- (expt (csc ,arg) 2)) ,(derive arg)))
  122. (defmacro define-equation-functions (name variable equation)
  123. (let ((derivative-name
  124. (intern
  125. (string-upcase
  126. (format nil "d/d~a-~a" variable name))))
  127. (derivative (derive equation)))
  128. `(progn
  129. (defun ,name (,variable)
  130. ,equation)
  131. (defun ,derivative-name (,variable)
  132. ,derivative))))
  133. (defmacro take-derivative (equation)
  134. (let ((derivative (derive equation)))
  135. `',derivative))
  136. ;;; End derive2