| Paste number 53083: | algebra.lisp |
| Pasted by: | NightShadow |
| 7 months, 1 week ago | |
| #lispcafe | Context in IRC logs | |
| Paste contents: |
| (in-package :com.teisenberger.math.algebra) (defun simplify (expression) (if (atom expression) (return-from simplify expression)) (if (eql (length expression) 1) (return-from simplify (first expression))) (setf expression (copy-list expression)) (dotimes (i (length expression)) (if (listp (nth i expression)) (setf (nth i expression) (simplify (nth i expression))))) (let ((operation (first expression)) (u (second expression)) (v (cddr expression))) (cond ((eql operation '-) (add `(,u ,@(negate v)))) ((eql operation '/) (multiply `(,u ,@(reciprocal v)))) ((eql operation 'sqrt) (exponentiate `(,u 1/2))) ((eql operation '+) (add (cdr expression))) ((eql operation '*) (multiply (cdr expression))) ((eql operation 'expt) (exponentiate (cdr expression))) ((eql operation 'log) (logarithm (cdr expression))) (t expression)))) ;(defun solve (expression-1 expression-2) ; Compare terms for ordering (defun compare-terms (term-1 term-2) (cond ((or (eql term-1 '+) (eql term-1 '-) (eql term-1 '*) (eql term-1 '/)) t) ((or (eql term-2 '+) (eql term-2 '-) (eql term-2 '*) (eql term-2 '/)) nil) ((and (numberp term-1) (numberp term-2)) (< term-1 term-2)) ((numberp term-1) t) ((numberp term-2) nil) ((atom term-1) t) ((atom term-2) nil) ((and (eql (first term-1) 'expt) (eql (first term-2) 'expt) (equalp (second term-1) (second term-2))) t) (t nil))) ; Order terms (defun order (expression) (cond ((atom expression) expression) (t (dotimes (i (length expression)) (let ((element (nth i expression))) (if (not (and (listp element) (not-sortablep (first element)))) (setf (nth i expression) (order (nth i expression)))))) (setf expression (sort expression #'compare-terms)) expression))) ; Checks to see if expression is not-sortable (defun not-sortablep (expression) (case expression ((expt sqrt sin cos log) t) (otherwise nil))) (defmacro update-terms (value old-value i j terms) `(setf (nth ,i ,terms) ,value ,terms (delete ,old-value ,terms :start ,j :end (1+ ,j)) ,j ,i)) ; Add a list of terms, no operation included (defun add (terms) (setf terms (order terms)) (do ((i 0 (1+ i))) ((>= i (length terms)) (if (> (length terms) 1) `(+ ,@terms) (first terms))) (do* ((j (1+ i) (1+ j)) (u (nth i terms) (nth i terms)) (v (nth j terms) (nth j terms))) ((>= j (length terms))) ;(format t "+Terms:~a~%" terms) (cond ; Next two lines, zero identity of addition ((equalp u 0) (update-terms v v i j terms)) ((equalp v 0) (update-terms u v i j terms)) ; If just numbers, evaluate ((and (numberp u) (numberp v)) (update-terms (+ u v) v i j terms)) ; Next two lines collapse nested addition ((and (listp v) (eql (first v) '+)) (update-terms (add `(,u ,@(cdr v))) v i j terms)) ((and (listp u) (eql (first u) '+)) (update-terms (add `(,v ,@(cdr u))) v i j terms)) ; If u and v are the same, group them into multiplication ((equalp u v) (update-terms (multiply `(2 ,u)) v i j terms)) ; Next two lines, same as above, except u or v can have a multiplier ((and (listp v) (eql (first v) '*) (equalp u (third v))) (update-terms (multiply `(,(add (list 1 (second v))) ,u)) v i j terms)) ((and (listp u) (eql (first u) '*) (equalp v (third u))) (update-terms (multiply `(,(add (list 1 (second u))) ,v)) v i j terms)) ; Same as above, except u and v can have a multiplier ((and (listp u) (listp v) (eql (first u) '*) (eql (first v) '*) (equalp (third u) (third v))) (update-terms (multiply `(,(add (list (second u) (second v))) ,(third u))) v i j terms)) ; log A + log B = log A*B ((and (listp u) (listp v) (eql (first u) 'log) (eql (first v) 'log)) (cond ; Both logs have implied bases ((= 2 (length v) (length u)) (update-terms (logarithm (list (multiply `(,(second u) ,(second v))))) v i j terms)) ; The next two lines are if one has an implied base ((and (eql (length u) 3) (eql (length v) 2) (eql (third u) 'e)) (update-terms (logarithm (list (multiply `(,(second u) ,(second v))))) v i j terms)) ((and (eql (length v) 3) (eql (length u) 2) (eql (third v) 'e)) (update-terms (logarithm (list (multiply `(,(second u) ,(second v))))) v i j terms)) ; No implied bases, but they are the same ((and (= 3 (length v) (length u)) (equalp (third v) (third u))) (update-terms (logarithm `(,(multiply (list (second u) (second v))) ,(third u))) v i j terms)))))))) ; Multiply a list of terms, no operations included (defun multiply (terms) (setf terms (order terms)) (do ((i 0 (1+ i))) ((>= i (length terms)) (if (> (length terms) 1) `(* ,@terms) (first terms))) (do* ((j (1+ i) (1+ j)) (u (nth i terms) (nth i terms)) (v (nth j terms) (nth j terms))) ((>= j (length terms))) ;(format t "*Terms:~a~%" terms) (cond ; Multiply by zero ((or (equalp v 0) (equalp u 0)) (update-terms 0 v i j terms)) ; Next two lines, multiply by one ((equalp u 1) (update-terms v v i j terms)) ((equalp v 1) (update-terms u v i j terms)) ; If u and v are numbers, just multiply ((and (numberp u) (numberp v)) (update-terms (* u v) v i j terms)) ; Next two lines collapse multiplication ((and (listp v) (eql (first v) '*)) (update-terms (multiply `(,u ,@(cdr v))) v i j terms)) ((and (listp u) (eql (first u) '*)) (update-terms (multiply `(,v ,@(cdr u))) v i j terms)) ; If u and v are the same, group as exponent ((equalp u v) (update-terms (exponentiate `(,u 2)) v i j terms)) ; Next two lines are the same as above, except u or v can be an exponent ((and (listp u) (eql (first u) 'expt) (equalp (second u) v)) (update-terms (exponentiate `(,v ,(add (list (third u) 1)))) v i j terms)) ((and (listp v) (eql (first v) 'expt) (equalp (second v) u)) (update-terms (exponentiate `(,u ,(add (list (third v) 1)))) v i j terms)) ; Same as previous two lines, except u and v are exponents ((and (listp u) (listp v) (eql (first u) 'expt) (eql (first v) 'expt) (equalp (second u) (second v))) (update-terms (exponentiate `(,(second u) ,(add (list (third u) (third v))))) v i j terms)))))) ; Handle an exponent (defun exponentiate (terms) ;(format t "^Terms:~a~%" terms) (let ((base (first terms)) (power (second terms))) (cond ; Power of 0 ((equalp power 0) 1) ((and (equalp base 0) (numberp power) (< power 0)) (error "Division by zero")) ; Base and power are numbers ((and (numberp base) (numberp power)) (expt base power)) ; Nested exponents ((and (listp base) (eql (first base) 'expt)) (exponentiate `(,(second base) ,(multiply (list (third base) power))))) ; Power is a logarithm of same base ((and (listp power) (eql (first power) 'log)) (cond ((and (eql (length power) 3) (equalp base (third power))) (second power)) ((and (eql (length power) 2) (eql base 'e)) (second power)) (t `(expt ,base ,power)))) (t `(expt ,base ,power))))) ; Handle logarithms (defun logarithm (terms) ;(format t "logTerms:~a~%" terms) ; If no base, default to e (if (eql (length terms) 1) (setf terms (append terms '(e)))) (let ((value (first terms)) (base (second terms))) (cond ; Value of 1 ((equalp value 1) 0) ; Value and base are the same ((equalp value base) 1) ; Base and value are numbers ((and (numberp base) (numberp value)) (log base value)) ; Logarithm of an exponent ((and (listp value) (eql (first value) 'expt)) (multiply `(,(third value) ,(logarithm (list (second value) base))))) ; Otherwise, just return log. Drop base for base e (t (if (eql base 'e) `(log ,value) `(log ,value ,base)))))) ; Negate a list of terms, no operation included (defun negate (terms) (let ((result (copy-tree terms))) (dotimes (x (length result)) (setf (nth x result) (multiply `(-1 ,(nth x result))))) result)) ; Find the reciprocal of all terms in a list (defun reciprocal (terms) (let ((result (copy-tree terms))) (dotimes (x (length result)) (setf (nth x result) (exponentiate `(,(nth x result) -1)))) result)) |
This paste has no annotations.