manipulation.org 21 KB
Simple Algebraic Manipulation
COMMENT Export
(save-buffer)
(let ((org-confirm-babel-evaluate
(lambda (lang body)
(declare (ignorable lang body))
nil)))
(org-latex-export-to-pdf))
COMMENT Tangle
(save-buffer)
(let ((python-indent-offset 4))
(org-babel-tangle))
Introduction nonum
CLOSED: [2016-05-01 Sun 14:33]
As a part of my lisp-based Computer Algebra System, an algebraic manipulation toolkit is required. This will be used to simplify equations, or for that matter solve them. This creates this toolkit, but does not create a complete simplifier or solver. It does this by providing manipulators and automatic rewriters. These together will provide simplification and solving utilities.
TOC ignore
WORKING Rewrite Rules [0/5]
Foo
Match Expressions
Foo
(defun generate-match-expression (on arity &optional (type '=))
(check-type on symbol)
(check-type type (member = > >=))
(check-type arity (integer 0))
(case type
(=
`(and (eq function ',on)
(= arg-count ,arity)))
(>
`(and (eq function ',on)
(> arg-count ,arity)))
(>=
`(and (eq function ',on)
(>= arg-count ,arity)))))
Define Rule
Foo
(defmacro defrule (name (on arity &optional (type '=)) (&rest arguments) &body expansion)
(let ((match-expression (generate-match-expression on arity type))
(test-name (symbolicate name '-test))
(expansion-name (symbolicate name '-expansion)))
`(progn
(defun ,test-name (function &rest arguments &aux (arg-count (length arguments)))
,match-expression)
(defun ,expansion-name (,@arguments)
,@expansion)
(setf (aget *rules* ',name)
(make-rule :name ',name
:test-function #',test-name
:expansion-function #',expansion-name))
',name)))
Rule Storage
Foo
(defstruct (rule (:type list))
name test-function expansion-function)
(defvar *rules* '())
Rule Retrieval
Foo
Rule Application
Foo
WORKING Expression Typing [0/5]
<<classification-storage>> <<define-classification>> <<check-classification>> <<classify-expression>> <<possible-classifications>>
WORKING Classification Storage
(defvar *classifications* '())
WORKING Define Classification
(defmacro defclassification (name &body body)
`(progn
(defun ,(symbolicate name '-classifier) (expression &aux (length (if (listp expression) (length expression) 1)))
(declare (ignorable length))
,@body)
(pushnew '(,name . ,(symbolicate name '-classifier)) *classifications*)
',name))
WORKING Check Classification
(defun expression-type-p (expression type)
(if (eq '* type)
t
(funcall (cdr (assoc type *classifications*))
expression)))
WORKING Classify Expression
(defun classify (expression)
(remove-if #'null
(map 'list #'(lambda (name-and-checker)
(let ((name (car name-and-checker))
(checker (cdr name-and-checker)))
(if (funcall checker expression)
name
nil)))
,*classifications*)))
(defun expression-type (expression)
(first (classify expression)))
WORKING Classifications [0/11]
<<classify-numbers>> <<classify-variables>> <<classify-additives>> <<classify-subtractives>> <<classify-powers>> <<classify-exponentials>> <<classify-multiplicatives>> <<classify-logarithmics>> <<classify-rationals>> <<classify-polynomial-term>> <<classify-polynomials>>
WORKING Numbers
(defclassification numeric
(numberp expression))
WORKING Variables
(defclassification variable
(symbolp expression))
WORKING Additives
(defclassification additive
(when (listp expression)
(eq '+ (first expression))))
WORKING Subtractive
(defclassification subtractive
(when (listp expression)
(eq '- (first expression))))
WORKING Powers
(defclassification power
(when (listp expression)
(and (eq 'expt (first expression))
(expression-type-p (second expression) 'variable)
(expression-type-p (third expression) 'numeric))))
WORKING Exponentials
(defclassification natural-exponential
(when (listp expression)
(and (= 2 length)
(eq 'exp (first expression)))))
(defclassification exponential
(when (listp expression)
(and (= 3 length)
(eq 'expt (first expression)))))
WORKING Multiplicatives
(defclassification multiplicative
(when (listp expression)
(eq '* (first expression))))
WORKING Logarithmics
(defclassification natural-logarithmic
(when (listp expression)
(and (= 2 length)
(eq 'log (first expression)))))
(defclassification logarithmic
(when (listp expression)
(and (= 3 length)
(eq 'log (first expression)))))
WORKING Rationals
(defclassification rational
(when (listp expression)
(and (= 3 length)
(eq '/ (first expression)))))
WORKING Polynomial Terms
(defclassification polynomial-term
(or (expression-type-p expression 'numeric)
(expression-type-p expression 'variable)
(expression-type-p expression 'power)
(and (expression-type-p expression 'multiplicative)
(= (length (rest expression)) 2)
(or (and (expression-type-p (second expression) 'numeric)
(or (expression-type-p (third expression) 'power)
(expression-type-p (third expression) 'variable)))
(and (expression-type-p (third expression) 'numeric)
(or (expression-type-p (second expression) 'power)
(expression-type-p (second expression) 'variable)))))))
WORKING Polynomials
(defclassification polynomial
(when (listp expression)
(and (or (eq '- (first expression))
(eq '+ (first expression)))
(reduce #'(lambda (a b)
(and a b))
(map 'list
#'(lambda (the-expression)
(expression-type-p the-expression 'polynomial-term))
(rest expression))))))
WORKING Term Collector
Foo
(defun collect-terms (expression)
(let ((terms (rest expression)))
))
WORKING Polynomial Related Functions
(defun coefficient (term)
(when (expression-type-p term 'polynomial-term)
(if (expression-type-p term 'multiplicative)
(second term)
(if (expression-type-p term 'variable)
1
term))))
(defun term-variable (term)
(when (expression-type-p term 'polynomial-term)
(cond
((expression-type-p term 'multiplicative) (second (third term)))
((expression-type-p term 'power) (second term))
(t nil))))
(defun get-power (term)
(cond
((expression-type-p term 'polynomial-term) (third (third term)))
((expression-type-p term 'power) (third term))
(t 0)))
(defun same-order-p (term-a term-b)
(= (get-power term-a)
(get-power term-b)))
(defun same-variable-p (term-a term-b)
(eq (term-variable term-a)
(term-variable term-b)))
(defun single-term-combinable-p (term-a term-b)
(and (same-order-p term-a term-b)
(same-variable-p term-a term-b)))
WORKING Expression Manipulators [0/7]
Foo
<<define-expression-manipulator>> <<external-manipulator>> <<addition-manipulator>> <<subtraction-manipulator>>
WORKING Define Expression Manipulator
(defvar *manipulator-map* '())
(defun gen-args-list (count)
(let ((letters '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
(loop for i from 1 to count
collect (symbolicate 'expression- (nth (1- i) letters)))))
(defmacro defoperation (name arity short)
(check-type name symbol)
(check-type arity (integer 1 26))
(check-type short symbol)
(let* ((args (gen-args-list arity))
(rules-name (symbolicate '*manipulators- name '*))
(base-manipulator-name (symbolicate name '-manipulator-))
(manipulator-define-name (symbolicate 'define- name '-manipulator))
(is-applicable-name (symbolicate name '-is-applicable-p))
(get-operations-name (symbolicate 'get- name '-manipulators))
(type-check-list (let ((i 0))
(loop for arg in args
collect (prog1
`(expression-type-p ,arg (nth ,i types))
(incf i))))))
`(progn
(push '(,short . ,name) *manipulator-map*)
(defvar ,rules-name '())
(defun ,is-applicable-name (types ,@args)
(and ,@type-check-list))
(defun ,get-operations-name (,@args)
(remove-if #'null
(map 'list #'(lambda (option)
(let ((types (car option))
(name (cdr option)))
(if (,is-applicable-name types ,@args)
name)))
,rules-name)))
(defun ,name (,@args)
(funcall (first (,get-operations-name ,@args))
,@args))
(defmacro ,manipulator-define-name ((&rest types) &body body)
(let ((manipulator-name (symbolicate ',base-manipulator-name (format nil "~a" (1+ (length ,rules-name))))))
`(progn
(setf ,',rules-name (append ,',rules-name '((,types . ,manipulator-name))))
(defun ,manipulator-name ,',args
,@body)))))))
;; (defmacro defmanipulator (name arity &body body)
;; (cond
;; ((listp arity)
;; `(defun ,name (,@arity)
;; ,@body))
;; ((typep arity '(integer 1 26))
;; (if (= arity 1)
;; `(defun ,name (expression)
;; ,@body)
;; (let* ((letters '(a b c d e f g h i j k l m n o p q r s t u v w x y z))
;; (args (loop for i from 1 to arity
;; collect (symbolicate 'expression- (nth (1- i) letters)))))
;; `(defun ,name (,@args)
;; ,@body))))
;; ((eq arity 'rest)
;; `(defun ,name (&rest expressions)
;; ,@body))))
WORKING External Manipulator
;; (defun manipulate (action &rest expressions) ;; (case action ;; (+ ;; (reduce #'add expressions)) ;; (- ;; (reduce #'subtract expressions)) ;; (* ;; (reduce #'multiply expressions)) ;; (/ ;; (reduce #'divide expressions)) ;; (sin ;; (reduce #'manip-sin expressions)) ;; (cos ;; (reduce #'manip-cos expressions)) ;; (tan ;; (reduce #'manip-tan expressions)) ;; (expt ;; (reduce #'powers expressions))))
WORKING Addition
Foo
(defoperation add 2 +)
(define-add-manipulator (numeric numeric)
(+ expression-a expression-b))
(define-add-manipulator (numeric additive)
(let ((total expression-a)
(remainder (rest expression-b))
(non-numeric '()))
(dolist (element remainder)
(if (expression-type-p element 'numeric)
(incf total element)
(push element non-numeric)))
(cond
((null non-numeric)
total)
((= 0 total)
`(+ ,@non-numeric))
(t
`(+ ,total ,@non-numeric)))))
(define-add-manipulator (additive additive)
(let ((total 0)
(elements (append (rest expression-a)
(rest expression-b)))
(non-numeric '()))
(dolist (element elements)
(if (expression-type-p element 'numeric)
(incf total element)
(push element non-numeric)))
(cond
((null non-numeric)
total)
((= 0 total)
`(+ ,@non-numeric))
(t
`(+ ,total ,@non-numeric)))))
(define-add-manipulator (numeric subtractive)
(let ((total expression-a)
(the-other (rest expression-b))
(non-numeric '()))
(dolist (element the-other)
(if (expression-type-p element 'numeric)
(decf total element)
(push element non-numeric)))
(cond
((null non-numeric)
total)
((= 0 total)
`(+ ,@non-numeric))
(t
`(+ ,total (-,@non-numeric))))))
(define-add-manipulator (numeric polynomial-term)
`(+ ,expression-a ,expression-b))
(define-add-manipulator (polynomial-term polynomial-term)
(if (single-term-combinable-p expression-a expression-b)
(let ((new-coefficient (+ (coefficient expression-a)
(coefficient expression-b)))
(variable (term-variable expression-a))
(power (get-power expression-a)))
`(* ,new-coefficient (expt ,variable ,new-power)))
`(+ ,expression-a ,expression-b)))
(define-add-manipulator (* numeric)
(add expression-b expression-a))
WORKING Subtraction
Foo
(defoperation subtract 2 -)
(define-subtract-manipulator (numeric numeric)
(- expression-a expression-b))
(define-subtract-manipulator (numeric subtractive)
(let ((total expression-a)
(elements (rest expression-b))
(non-numeric '()))
(dolist (element elements)
(if (expression-type-p element 'numeric)
(decf total element)
(push element non-numeric)))
(cond
((null non-numeric)
total)
((= 0 total)
`(- ,@(reverse non-numeric)))
(t
`(- ,total ,@(reverse non-numeric))))))
(define-subtract-manipulator (* numeric)
(subtract expression-b expression-a))
Multiplication
Foo
Division
Foo
Trigonometric
Foo
WORKING Packaging
Foo
(defpackage #:manipulator
(:use #:cl)
(:import-from #:alexandria
#:symbolicate)
(:export #:manipulate))
(in-package #:manipulator)
<<determine-expression-type>>
<<polynomial-related-functions>>
<<collect-terms>>
<<expression-manipulation>>