Created
November 3, 2013 15:21
-
-
Save Eskatrem/7291381 to your computer and use it in GitHub Desktop.
Proof of concept of a program that makes the derivative operator a first class citizen.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(defparameter *maths-functions* (list)) | |
(defmacro defun-maths (func-name args core) | |
"appends the code of func-name into maths-functions." | |
`(progn | |
(push (list :name (quote ,func-name) :variable (quote ,args) :core (quote ,core)) *maths-functions*) | |
(defun ,func-name ,args ,core))) | |
(defun get-source (func-name) | |
(car (remove-if-not (lambda (f) (eql (getf f :name) func-name)) *maths-functions* | |
))) | |
(defparameter *operators* | |
(list '* '- '/ '+)) | |
(defparameter *derivatives* | |
(list 'cos '(* -1 (sin %)) | |
'sin '(cos %) | |
'tan '(+ 1 (* (tan %) (tan %))) | |
'log '(/ 1 %) | |
'exp '(exp %) | |
'+ '+ | |
)) | |
(defun get-derivative (func variable) | |
(let ((der (getf *derivatives* func))) | |
(cond | |
((not (null der)) der) | |
((eql func variable) 1) | |
(T 0)))) | |
(defun operatorp (symb) | |
(member symb *operators*)) | |
(defun derivative (expr variable) | |
(if (listp expr) | |
(derivative-list expr variable) | |
(get-derivative expr variable))) | |
(defun derivative-op (op args variable) | |
(let ((der (lambda (a) ( derivative a variable))) | |
(u (car args)) | |
(v (cadr args))) | |
(cond ((eql '+ op) (cons '+ (mapcar der args))) | |
((eql '* op) (cons '+ (list (list '* | |
(derivative u variable) v) | |
(list '* u (derivative v variable))))) | |
((eql '- op) (cons '- (mapcar der args))) | |
((eql '/ op) (cons '/ (list | |
(list '- (list '* (funcall der u) v) | |
(list '* u (funcall der v))) | |
(list '* v v))))))) | |
(defun subst-recursive (lst target replacement) | |
(cond ((null lst) nil) | |
((not (listp lst)) (if (eql lst target) replacement lst)) | |
(T (cons (subst-recursive (car lst) target replacement) (subst-recursive (cdr lst) target replacement))))) | |
(defun derivative-list (expr variable) | |
(let* ((func (car expr)) | |
(args (cdr expr)) | |
(der (get-derivative func variable))) | |
(cond ((operatorp func) (derivative-op func args variable)) | |
(T (list (cons '* (mapcar (lambda ( arg) (derivative arg variable)) args)) (subst-recursive der '% args)))))) | |
(defun create-derivative-list-defun (func-name derivative-name) | |
(let* ((func-data (get-source func-name)) | |
(variable (getf func-data :variable)) | |
(core (getf func-data :core)) | |
(var (car variable)) | |
(der (derivative core var))) | |
(list 'defun-maths derivative-name variable der))) | |
(defun make-derivative (func-name derivative-name) | |
(let ((define-list (create-derivative-list-defun func-name derivative-name))) | |
(eval define-list))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment