daveg@csvax.caltech.edu (David Gillespie) (06/06/90)
Posting-number: Volume 13, Issue 36
Submitted-by: daveg@csvax.caltech.edu (David Gillespie)
Archive-name: gmcalc/part10
---- Cut Here and unpack ----
#!/bin/sh
# this is part 10 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc-ext.el continued
#
CurArch=10
if test ! -r s2_seq_.tmp
then echo "Please unpack part 1 first!"
exit 1; fi
( read Scheck
if test "$Scheck" != $CurArch
then echo "Please unpack part $Scheck next!"
exit 1;
else exit 0; fi
) < s2_seq_.tmp || exit 1
echo "x - Continuing file calc-ext.el"
sed 's/^X//' << 'SHAR_EOF' >> calc-ext.el
X ''math-integral-2)
X (list 'list
X (list 'function
X (append '(lambda (u v))
X code)))))))
X (if (symbolp funcs) (list funcs) funcs)))
X)
X(put 'math-defintegral-2 'lisp-indent-hook 1)
X
X(math-defintegral calcFunc-inv
X (math-integral (math-div 1 u)))
X
X(math-defintegral calcFunc-conj
X (let ((int (math-integral u)))
X (and int
X (list 'calcFunc-conj int))))
X
X(math-defintegral calcFunc-deg
X (let ((int (math-integral u)))
X (and int
X (list 'calcFunc-deg int))))
X
X(math-defintegral calcFunc-rad
X (let ((int (math-integral u)))
X (and int
X (list 'calcFunc-rad int))))
X
X(math-defintegral calcFunc-re
X (let ((int (math-integral u)))
X (and int
X (list 'calcFunc-re int))))
X
X(math-defintegral calcFunc-im
X (let ((int (math-integral u)))
X (and int
X (list 'calcFunc-im int))))
X
X(math-defintegral calcFunc-sqrt
X (and (equal u math-integ-var)
X (math-mul '(frac 2 3)
X (list 'calcFunc-sqrt (math-pow u 3)))))
X
X(math-defintegral calcFunc-exp
X (and (equal u math-integ-var)
X (list 'calcFunc-exp u)))
X
X(math-defintegral calcFunc-ln
X (or (and (equal u math-integ-var)
X (math-sub (math-mul u (list 'calcFunc-ln u)) u))
X (and (eq (car u) '*)
X (math-integral (math-add (list 'calcFunc-ln (nth 1 u))
X (list 'calcFunc-ln (nth 2 u)))))
X (and (eq (car u) '/)
X (math-integral (math-sub (list 'calcFunc-ln (nth 1 u))
X (list 'calcFunc-ln (nth 2 u)))))
X (and (eq (car u) '^)
X (math-integral (math-mul (nth 2 u)
X (list 'calcFunc-ln (nth 1 u)))))))
X
X(math-defintegral calcFunc-log10
X (and (equal u math-integ-var)
X (math-sub (math-mul u (list 'calcFunc-ln u))
X (math-div u (list 'calcFunc-ln 10)))))
X
X(math-defintegral-2 calcFunc-log
X (math-integral (math-div (list 'calcFunc-ln u)
X (list 'calcFunc-ln v))))
X
X(math-defintegral calcFunc-sin
X (and (equal u math-integ-var)
X (math-neg (math-from-radians-2 (list 'calcFunc-cos u)))))
X
X(math-defintegral calcFunc-cos
X (and (equal u math-integ-var)
X (math-from-radians-2 (list 'calcFunc-sin u))))
X
X(math-defintegral calcFunc-tan
X (and (equal u math-integ-var)
X (math-neg (math-from-radians-2
X (list 'calcFunc-ln (list 'calcFunc-cos u))))))
X
X(math-defintegral calcFunc-arcsin
X (and (equal u math-integ-var)
X (math-add (math-mul u (list 'calcFunc-arcsin u))
X (math-from-radians-2
X (list 'calcFunc-sqrt (math-sub 1 (math-sqr u)))))))
X
X(math-defintegral calcFunc-arccos
X (and (equal u math-integ-var)
X (math-sub (math-mul u (list 'calcFunc-arccos u))
X (math-from-radians-2
X (list 'calcFunc-sqrt (math-sub 1 (math-sqr u)))))))
X
X(math-defintegral calcFunc-arctan
X (and (equal u math-integ-var)
X (math-sub (math-mul u (list 'calcFunc-arctan u))
X (math-from-radians-2
X (math-div (list 'calcFunc-ln (math-add 1 (math-sqr u)))
X 2)))))
X
X(math-defintegral calcFunc-sinh
X (and (equal u math-integ-var)
X (list 'calcFunc-cosh u)))
X
X(math-defintegral calcFunc-cosh
X (and (equal u math-integ-var)
X (list 'calcFunc-sinh u)))
X
X(math-defintegral calcFunc-tanh
X (and (equal u math-integ-var)
X (list 'calcFunc-ln (list 'calcFunc-cosh u))))
X
X(math-defintegral calcFunc-arcsinh
X (and (equal u math-integ-var)
X (math-sub (math-mul u (list 'calcFunc-arcsinh u))
X (list 'calcFunc-sqrt (math-add (math-sqr u) 1)))))
X
X(math-defintegral calcFunc-arccosh
X (and (equal u math-integ-var)
X (math-sub (math-mul u (list 'calcFunc-arccosh u))
X (list 'calcFunc-sqrt (math-sub 1 (math-sqr u))))))
X
X(math-defintegral calcFunc-arctanh
X (and (equal u math-integ-var)
X (math-sub (math-mul u (list 'calcFunc-arctan u))
X (math-div (list 'calcFunc-ln
X (math-add 1 (math-sqr u)))
X 2))))
X
X;;; 1 / (ax^2 + bx + c) forms.
X(math-defintegral-2 /
X (and (not (math-expr-contains u math-integ-var))
X (let ((p1 (math-is-polynomial v math-integ-var 2))
X q rq part)
X (cond ((null p1) nil)
X ((null (cdr (cdr p1)))
X (math-mul u (math-div (list 'calcFunc-ln v) (nth 1 p1))))
X ((math-zerop
X (setq part (math-add (math-mul 2
X (math-mul (nth 2 p1)
X math-integ-var))
X (nth 1 p1))
X q (math-sub (math-mul 4
X (math-mul (nth 0 p1)
X (nth 2 p1)))
X (math-sqr (nth 1 p1)))))
X (math-div (math-mul -2 u) part))
X ((math-negp q)
X (setq rq (list 'calcFunc-sqrt (math-neg q)))
X (math-div (math-mul u
X (list 'calcFunc-ln
X (math-div (math-add part rq)
X (math-sub part rq))))
X rq))
X (t
X (setq rq (list 'calcFunc-sqrt q))
X (math-div (math-mul 2
X (math-mul u
X (list 'calcFunc-arctan
X (math-div part rq))))
X rq))))))
X
X
X
X;;; Attempt to reduce lhs = rhs to solve-var = rhs', where solve-var appears
X;;; in lhs but not in rhs or rhs'; return rhs'.
X(defun math-try-solve-for (lhs rhs) ; uses global values: solve-*.
X (let (t1 t2 t3)
X (cond ((equal lhs solve-var)
X rhs)
X ((Math-primp lhs)
X nil)
X ((setq t2 (math-polynomial-base
X lhs
X (function (lambda (b)
X (and (setq t1 (math-is-polynomial lhs b 2))
X (math-expr-depends b solve-var)
X (not (equal b lhs)))))))
X (if (cdr (cdr t1))
X (math-try-solve-for
X t2
X (if (math-looks-evenp (nth 1 t1))
X (let ((halfb (math-div (nth 1 t1) 2)))
X (math-div
X (math-add
X (math-neg halfb)
X (math-solve-get-sign
X (math-normalize
X (list 'calcFunc-sqrt
X (math-add (math-sqr halfb)
X (math-mul (math-sub rhs (car t1))
X (nth 2 t1)))))))
X (nth 2 t1)))
X (math-div
X (math-add
X (math-neg (nth 1 t1))
X (math-solve-get-sign
X (math-normalize
X (list 'calcFunc-sqrt
X (math-add (math-sqr (nth 1 t1))
X (math-mul 4
X (math-mul (math-sub rhs
X (car t1))
X (nth 2 t1))))))))
X (math-mul 2 (nth 2 t1)))))
X (and (cdr t1)
X (math-try-solve-for t2
X (math-div (math-sub rhs (car t1))
X (nth 1 t1))))))
X ((eq (car lhs) '+)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X (math-sub rhs (nth 1 lhs))))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X (math-sub rhs (nth 2 lhs))))))
X ((memq (car lhs) '(- calcFunc-eq))
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X (math-sub (nth 1 lhs) rhs)))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X (math-add rhs (nth 2 lhs))))))
X ((eq (car lhs) 'neg)
X (math-try-solve-for (nth 1 lhs) (math-neg rhs)))
X ((eq (car lhs) '*)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X (math-div rhs (nth 1 lhs))))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X (math-div rhs (nth 2 lhs))))))
X ((eq (car lhs) '/)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for (nth 2 lhs)
X (math-div (nth 1 lhs) rhs)))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (math-try-solve-for (nth 1 lhs)
X (math-mul rhs (nth 2 lhs))))
X ((and (setq t1 (math-is-polynomial (nth 1 lhs) solve-var 2))
X (setq t2 (math-is-polynomial (nth 2 lhs) solve-var 2)))
X (math-try-solve-for (math-build-polynomial-expr
X (math-poly-mix t2 rhs t1 -1)
X solve-var)
X 0))
X ((setq t3 (math-polynomial-base
X (nth 1 lhs)
X (function (lambda (b)
X (and (math-expr-depends b solve-var)
X (setq t1 (math-is-polynomial
X (nth 1 lhs) b 2))
X (setq t2 (math-is-polynomial
X (nth 2 lhs) b 2)))))))
X (math-try-solve-for (math-build-polynomial-expr
X (math-poly-mix t2 rhs t1 -1)
X t3)
X 0))))
X ((eq (car lhs) '^)
X (cond ((not (math-expr-depends (nth 1 lhs) solve-var))
X (math-try-solve-for
X (nth 2 lhs)
X (math-add (math-normalize
X (list 'calcFunc-log rhs (nth 1 lhs)))
X (math-div
X (math-mul 2
X (math-mul '(var pi var-pi)
X (math-solve-get-int
X '(var i var-i))))
X (math-normalize
X (list 'calcFunc-ln (nth 1 lhs)))))))
X ((not (math-expr-depends (nth 2 lhs) solve-var))
X (cond ((math-equal-int (nth 2 lhs) 2)
X (math-try-solve-for
X (nth 1 lhs)
X (math-solve-get-sign
X (math-normalize (list 'calcFunc-sqrt rhs)))))
X (t (math-try-solve-for
X (nth 1 lhs)
X (math-mul
X (math-normalize
X (list 'calcFunc-exp
X (if (Math-realp (nth 2 lhs))
X (math-div (math-mul
X '(var pi var-pi)
X (math-solve-get-int
X '(var i var-i)))
X (math-div (nth 2 lhs) 2))
X (math-div (math-mul
X 2
X (math-mul
X '(var pi var-pi)
X (math-solve-get-int
X '(var i var-i))))
X (nth 2 lhs)))))
X (math-normalize
X (list '^
X rhs
X (math-div 1 (nth 2 lhs)))))))))))
X ((and (eq (car lhs) '%)
X (not (math-expr-depends (nth 2 lhs) solve-var)))
X (math-try-solve-for (nth 1 lhs) (math-add rhs
X (math-solve-get-int
X (nth 2 lhs)))))
X ((and (= (length lhs) 2)
X (symbolp (car lhs))
X (setq t1 (get (car lhs) 'math-inverse))
X (setq t2 (funcall t1 rhs)))
X (math-try-solve-for (nth 1 lhs) (math-normalize t2)))
X (t
X (calc-record-why "No inverse known" lhs)
X nil)))
X)
X
X(defun math-get-from-counter (name)
X (let ((ctr (assq name calc-command-flags)))
X (if ctr
X (setcdr ctr (1+ (cdr ctr)))
X (setq ctr (cons name 1)
X calc-command-flags (cons ctr calc-command-flags)))
X (cdr ctr))
X)
X
X(defun math-solve-get-sign (val)
X (if solve-full
X (let ((var (concat "s" (math-get-from-counter 'solve-sign))))
X (math-mul (list 'var (intern var) (intern (concat "var-" var)))
X val))
X (calc-record-why "Choosing positive solution")
X val)
X)
X
X(defun math-solve-get-int (val)
X (if solve-full
X (let ((var (concat "n" (math-get-from-counter 'solve-int))))
X (math-mul val
X (list 'var (intern var) (intern (concat "var-" var)))))
X (calc-record-why "Choosing 0 for arbitrary integer in solution")
X 0)
X)
X
X(defun math-looks-evenp (expr)
X (if (Math-integerp expr)
X (math-evenp expr)
X (if (memq (car expr) '(* /))
X (math-looks-evenp (nth 1 expr))))
X)
X
X(defun math-solve-for (lhs rhs solve-var solve-full)
X (if (math-expr-contains rhs solve-var)
X (math-solve-for (math-sub lhs rhs) 0 solve-var solve-full)
X (and (math-expr-contains lhs solve-var)
X (math-try-solve-for lhs rhs)))
X)
X
X(defun calcFunc-solve (expr var)
X (let ((res (math-solve-for expr 0 var nil)))
X (if res
X (list 'calcFunc-eq var res)
X (list 'calcFunc-solve expr var)))
X)
X
X(defun calcFunc-fsolve (expr var)
X (let ((res (math-solve-for expr 0 var t)))
X (if res
X (list 'calcFunc-eq var res)
X (list 'calcFunc-fsolve expr var)))
X)
X
X(defun calcFunc-finv (expr var)
X (let ((res (math-solve-for expr math-integ-var var nil)))
X (if res
X (math-normalize (math-expr-subst res math-integ-var var))
X (list 'calcFunc-finv expr var)))
X)
X
X(defun calcFunc-ffinv (expr var)
X (let ((res (math-solve-for expr math-integ-var var t)))
X (if res
X (math-normalize (math-expr-subst res math-integ-var var))
X (list 'calcFunc-finv expr var)))
X)
X
X
X(put 'calcFunc-inv 'math-inverse
X (function (lambda (x) (math-div 1 x))))
X
X(put 'calcFunc-sqrt 'math-inverse
X (function (lambda (x) (math-sqr x))))
X
X(put 'calcFunc-conj 'math-inverse
X (function (lambda (x) (list 'calcFunc-conj x))))
X
X(put 'calcFunc-abs 'math-inverse
X (function (lambda (x) (math-solve-get-sign x))))
X
X(put 'calcFunc-deg 'math-inverse
X (function (lambda (x) (list 'calcFunc-rad x))))
X
X(put 'calcFunc-rad 'math-inverse
X (function (lambda (x) (list 'calcFunc-deg x))))
X
X(put 'calcFunc-ln 'math-inverse
X (function (lambda (x) (list 'calcFunc-exp x))))
X
X(put 'calcFunc-log10 'math-inverse
X (function (lambda (x) (list 'calcFunc-exp10 x))))
X
X(put 'calcFunc-lnp1 'math-inverse
X (function (lambda (x) (list 'calcFunc-expm1 x))))
X
X(put 'calcFunc-exp 'math-inverse
X (function (lambda (x) (math-add (math-normalize (list 'calcFunc-ln x))
X (math-mul 2
X (math-mul '(var pi var-pi)
X (math-solve-get-int
X '(var i var-i))))))))
X
X(put 'calcFunc-expm1 'math-inverse
X (function (lambda (x) (math-add (math-normalize (list 'calcFunc-lnp1 x))
X (math-mul 2
X (math-mul '(var pi var-pi)
X (math-solve-get-int
X '(var i var-i))))))))
X
X(put 'calcFunc-sin 'math-inverse
X (function (lambda (x) (let ((n (math-solve-get-int 1)))
X (math-add (math-mul (math-normalize
X (list 'calcFunc-arcsin x))
X (math-pow -1 n))
X (math-mul (math-half-circle t)
X n))))))
X
X(put 'calcFunc-cos 'math-inverse
X (function (lambda (x) (math-add (math-solve-get-sign
X (math-normalize
X (list 'calcFunc-arccos x)))
X (math-solve-get-int
X (math-full-circle t))))))
X
X(put 'calcFunc-tan 'math-inverse
X (function (lambda (x) (math-add (math-normalize (list 'calcFunc-arctan x))
X (math-solve-get-int
X (math-half-circle t))))))
X
X(put 'calcFunc-arcsin 'math-inverse
X (function (lambda (x) (math-normalize (list 'calcFunc-sin x)))))
X
X(put 'calcFunc-arccos 'math-inverse
X (function (lambda (x) (math-normalize (list 'calcFunc-cos x)))))
X
X(put 'calcFunc-arctan 'math-inverse
X (function (lambda (x) (math-normalize (list 'calcFunc-tan x)))))
X
X(put 'calcFunc-sinh 'math-inverse
X (function (lambda (x) (let ((n (math-solve-get-int 1)))
X (math-add (math-mul (math-normalize
X (list 'calcFunc-arctanh x))
X (math-pow -1 n))
X (math-mul (math-half-circle t)
X (math-mul
X '(var i var-i)
X n)))))))
X
X(put 'calcFunc-cosh 'math-inverse
X (function (lambda (x) (math-add (math-solve-get-sign
X (math-normalize
X (list 'calcFunc-arctanh x)))
X (math-mul (math-full-circle t)
X (math-solve-get-int
X '(var i var-i)))))))
X
X(put 'calcFunc-tanh 'math-inverse
X (function (lambda (x) (math-add (math-normalize
X (list 'calcFunc-arctanh x))
X (math-mul (math-half-circle t)
X (math-solve-get-int
X '(var i var-i)))))))
X
X(put 'calcFunc-arcsinh 'math-inverse
X (function (lambda (x) (math-normalize (list 'calcFunc-sinh x)))))
X
X(put 'calcFunc-arccosh 'math-inverse
X (function (lambda (x) (math-normalize (list 'calcFunc-cosh x)))))
X
X(put 'calcFunc-arctanh 'math-inverse
X (function (lambda (x) (math-normalize (list 'calcFunc-tanh x)))))
X
X
X
X(defun calcFunc-taylor (expr var num)
X (let ((x0 0) (v var))
X (if (memq (car-safe var) '(+ - calcFunc-eq))
X (setq x0 (if (eq (car var) '+) (math-neg (nth 2 var)) (nth 2 var))
X v (nth 1 var)))
X (or (and (eq (car-safe v) 'var)
X (math-expr-contains expr v)
X (natnump num)
X (let ((accum (math-expr-subst expr v x0))
X (var2 (if (eq (car var) 'calcFunc-eq)
X (cons '- (cdr var))
X var))
X (n 0)
X (nfac 1)
X (fprime expr))
X (while (and (<= (setq n (1+ n)) num)
X (setq fprime (calcFunc-deriv fprime v nil t)))
X (setq fprime (math-simplify fprime)
X nfac (math-mul nfac n)
X accum (math-add accum
X (math-div (math-mul (math-pow var2 n)
X (math-expr-subst
X fprime v x0))
X nfac))))
X (and fprime
X (math-normalize accum))))
X (list 'calcFunc-taylor expr var num)))
X)
X
X
X
X
X;;; Simple operations on expressions.
X
X;;; Return number of ocurrences of thing in expr, or nil if none.
X(defun math-expr-contains (expr thing)
X (cond ((equal expr thing) 1)
X ((Math-primp expr) nil)
X (t
X (let ((num 0))
X (while (setq expr (cdr expr))
X (setq num (+ num (or (math-expr-contains (car expr) thing) 0))))
X (and (> num 0)
X num))))
X)
X
X;;; Return non-nil if any variable of thing occurs in expr.
X(defun math-expr-depends (expr thing)
X (if (Math-primp thing)
X (and (eq (car-safe thing) 'var)
X (math-expr-contains expr thing))
X (while (and (setq thing (cdr thing))
X (not (math-expr-depends expr (car thing)))))
X thing)
X)
X
X;;; Substitute all occurrences of old for new in expr (non-destructive).
X(defun math-expr-subst (expr old new)
X (math-expr-subst-rec expr)
X)
X
X(defun math-expr-subst-rec (expr)
X (cond ((equal expr old) new)
X ((Math-primp expr) expr)
X ((memq (car expr) '(calcFunc-deriv
X calcFunc-tderiv))
X (if (= (length expr) 2)
X (if (equal (nth 1 expr) old)
X (append expr (list new))
X expr)
X (list (car expr) (nth 1 expr)
X (math-expr-subst-rec (nth 2 expr)))))
X (t
X (cons (car expr)
X (mapcar 'math-expr-subst-rec (cdr expr)))))
X)
X
X;;; Various measures of the size of an expression.
X(defun math-expr-weight (expr)
X (if (Math-primp expr)
X 1
X (let ((w 1))
X (while (setq expr (cdr expr))
X (setq w (+ w (math-expr-weight (car expr)))))
X w))
X)
X
X(defun math-expr-height (expr)
X (if (Math-primp expr)
X 0
X (let ((h 0))
X (while (setq expr (cdr expr))
X (setq h (max h (math-expr-height (car expr)))))
X (1+ h)))
X)
X
X
X
X
X;;; Polynomial operations (to support the integrator and solve-for).
X
X(defun math-collect-terms (expr base)
X (let ((p (math-is-polynomial expr base 20 t)))
X (if (cdr p)
X (math-build-polynomial-expr p base)
X expr))
X)
X
X;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
X;;; else return nil if not in polynomial form. If "loose", coefficients
X;;; may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
X(defun math-is-polynomial (expr var &optional degree loose)
X (let ((poly (math-is-poly-rec expr)))
X (and (or (null degree)
X (<= (length poly) (1+ degree)))
X poly))
X)
X
X(defun math-is-poly-rec (expr)
X (math-poly-simplify
X (or (cond ((equal expr var)
X (list 0 1))
X ((Math-objectp expr)
X (list expr))
X ((memq (car expr) '(+ -))
X (let ((p1 (math-is-poly-rec (nth 1 expr))))
X (and p1
X (let ((p2 (math-is-poly-rec (nth 2 expr))))
X (and p2
X (math-poly-mix p1 1 p2
X (if (eq (car expr) '+) 1 -1)))))))
X ((eq (car expr) 'neg)
X (mapcar 'math-neg (math-is-poly-rec (nth 1 expr))))
X ((eq (car expr) '*)
X (let ((p1 (math-is-poly-rec (nth 1 expr))))
X (and p1
X (let ((p2 (math-is-poly-rec (nth 2 expr))))
X (and p2
X (or (null degree)
X (<= (- (+ (length p1) (length p2)) 2) degree))
X (math-poly-mul p1 p2))))))
X ((eq (car expr) '/)
X (and (not (math-expr-depends (nth 2 expr) var))
X (not (Math-zerop (nth 2 expr)))
X (let ((p1 (math-is-poly-rec (nth 1 expr))))
X (mapcar (function (lambda (x) (math-div x (nth 2 expr))))
X p1))))
X ((eq (car expr) '^)
X (and (natnump (nth 2 expr))
X (let ((p1 (math-is-poly-rec (nth 1 expr)))
X (n (nth 2 expr))
X (accum (list 1)))
X (and p1
X (or (null degree)
X (<= (* (1- (length p1)) n) degree))
X (progn
X (while (>= n 1)
X (setq accum (math-poly-mul accum p1)
X n (1- n)))
X accum)))))
X (t nil))
X (and (or (not (math-expr-depends expr var))
X loose)
X (not (memq (car expr) '(vec)))
X (list expr))))
X)
X
X;;; Check if expr is a polynomial in var; if so, return its degree.
X(defun math-polynomial-p (expr var)
X (cond ((equal expr var) 1)
X ((Math-primp expr) 0)
X ((memq (car expr) '(+ -))
X (let ((p1 (math-polynomial-p (nth 1 expr) var))
X (p2 (math-polynomial-p (nth 2 expr) var)))
X (and p1 p2 (max p1 p2))))
X ((eq (car expr) '*)
X (let ((p1 (math-polynomial-p (nth 1 expr) var))
X (p2 (math-polynomial-p (nth 2 expr) var)))
X (and p1 p2 (+ p1 p2))))
X ((eq (car expr) 'neg)
X (math-polynomial-p (nth 1 expr) var))
X ((and (eq (car expr) '/)
X (not (math-expr-depends (nth 1 expr) var)))
X (math-polynomial-p (nth 1 expr) var))
X ((and (eq (car expr) '^)
X (natnump (nth 2 expr)))
X (let ((p1 (math-polynomial-p (nth 1 expr) var)))
X (and p1 (* p1 (nth 2 expr)))))
X ((math-expr-depends expr var) nil)
X (t 0))
X)
X
X;;; Find the variable (or sub-expression) which is the base of polynomial expr.
X(defun math-polynomial-base (mpb-top-expr &optional mpb-pred)
X (or mpb-pred
X (setq mpb-pred (function (lambda (base) (math-polynomial-p
X mpb-top-expr base)))))
X (or (let ((const-ok nil))
X (math-polynomial-base-rec mpb-top-expr))
X (let ((const-ok t))
X (math-polynomial-base-rec mpb-top-expr)))
X)
X
X(defun math-polynomial-base-rec (mpb-expr)
X (and (not (Math-objvecp mpb-expr))
X (or (and (memq (car mpb-expr) '(+ - *))
X (or (math-polynomial-base-rec (nth 1 mpb-expr))
X (math-polynomial-base-rec (nth 2 mpb-expr))))
X (and (memq (car mpb-expr) '(/ neg))
X (math-polynomial-base-rec (nth 1 mpb-expr)))
X (and (eq (car mpb-expr) '^)
X (natnump (nth 2 mpb-expr))
X (math-polynomial-base-rec (nth 1 mpb-expr)))
X (and (or const-ok (math-expr-contains-vars mpb-expr))
X (funcall mpb-pred mpb-expr)
X mpb-expr)))
X)
X
X;;; Return non-nil if expr refers to any variables.
X(defun math-expr-contains-vars (expr)
X (or (eq (car-safe expr) 'var)
X (and (not (Math-primp expr))
X (progn
X (while (and (setq expr (cdr expr))
X (not (math-expr-contains-vars (car expr)))))
X expr)))
X)
X
X;;; Simplify a polynomial in list form by stripping off high-end zeros.
X;;; This always leaves the constant part, i.e., nil->nil and nonnil->nonnil.
X(defun math-poly-simplify (p)
X (and p
X (if (Math-zerop (nth (1- (length p)) p))
X (let ((pp (copy-sequence p)))
X (while (and (cdr pp)
X (Math-zerop (nth (1- (length pp)) pp)))
X (setcdr (nthcdr (- (length pp) 2) pp) nil))
X pp)
X p))
X)
X
X;;; Compute ac*a + bc*b for polynomials in list form a, b and
X;;; coefficients ac, bc. Result may be unsimplified.
X(defun math-poly-mix (a ac b bc)
X (and (or a b)
X (cons (math-add (math-mul (or (car a) 0) ac)
X (math-mul (or (car b) 0) bc))
X (math-poly-mix (cdr a) ac (cdr b) bc)))
X)
X
X;;; Multiply two polynomials in list form.
X(defun math-poly-mul (a b)
X (and a b
X (math-poly-mix b (car a)
X (math-poly-mul (cdr a) (cons 0 b)) 1))
X)
X
X;;; Build an expression from a polynomial list.
X(defun math-build-polynomial-expr (p var)
X (if p
X (let ((accum (car p))
X (n 0))
X (while (setq p (cdr p))
X (setq n (1+ n)
X accum (math-add (math-mul (car p) (math-pow var n)) accum)))
X accum))
X)
X
X
X
X
X;;; Units operations.
X
X(defvar math-standard-units
X '( ;; Length
X ( m nil "*Meter" )
X ( in "2.54 cm" "Inch" )
X ( ft "12 in" "Foot" )
X ( yd "3 ft" "Yard" )
X ( mi "5280 ft" "Mile" )
X ( au "1.495979e11 m" "Astronomical Unit" )
X ( lyr "9.46052e15 m" "Light Year" )
X ( pc "3.08568e16 m" "Parsec" )
X ( nmi "1852 m" "Nautical Mile" )
X ( fath "6 ft" "Fathom" )
X ( u "1 um" "Micron" )
X ( mil "in/1000" "Mil" )
X ( point "in/72" "Point" )
X ( Ang "1e-10 m" "Angstrom" )
X
X ;; Area
X ( hect "1000 m^2" "*Hectare" )
X ( acre "mi^2 / 640" "Acre" )
X ( b "1e-28 m^2" "Barn" )
X
X ;; Volume
X ( l "1e-3 m^3" "*Liter" )
X ( L "1e-3 m^3" "Liter" )
X ( gal "4 qt" "US Gallon" )
X ( qt "2 pt" "Quart" )
X ( pt "2 cup" "Pint" )
X ( cup "8 ozfl" "Cup" )
X ( ozfl "2 tbsp" "Fluid Ounce" )
X ( tbsp "3 tsp" "Tablespoon" )
X ( tsp "4.92892 ml" "Teaspoon" )
X ( galC "4.54609 l" "Canadian Gallon" )
X ( galUK "4.546092 l" "UK Gallon" )
X
X ;; Time
X ( s nil "*Second" )
X ( min "60 s" "Minute" )
X ( hr "60 min" "Hour" )
X ( day "24 hr" "Day" )
X ( wk "7 day" "Week" )
X ( yr "365.25 day" "Year" )
X ( Hz "1/s" "Hertz" )
X
X ;; Speed
X ( mph "mi/hr" "*Miles per hour" )
X ( kph "km/hr" "Kilometers per hour" )
X ( knot "nmi/hr" "Knot" )
X ( c "2.99792458e8 m/s" "Speed of light" )
X
X ;; Acceleration
X ( ga "9.80665 m/s^2" "*\"g\" acceleration" )
X
X ;; Mass
X ( g nil "*Gram" )
X ( lb "16 oz" "Pound (mass)" )
X ( oz "28.349523125 g" "Ounce (mass)" )
X ( ton "2000 lb" "Ton" )
X ( t "1000 kg" "Metric ton" )
X ( tonUK "1016.0469088 kg" "UK ton" )
X ( lbt "12 ozt" "Troy pound" )
X ( ozt "31.103475 g" "Troy ounce" )
X ( ct ".2 g" "Carat" )
X ( amu "1.6605655e-24 g" "Unified atomic mass" )
X
X ;; Force
X ( N "m kg/s^2" "*Newton" )
X ( dyn "1e-5 N" "Dyne" )
X ( gf "9.60665e-3 N" "Gram (force)" )
X ( lbf "4.44822161526 N" "Pound (force)" )
X ( kip "1000 lbf" "Kilopound (force)" )
X ( pdl "0.138255 N" "Poundal" )
X
X ;; Energy
X ( J "N m" "*Joule" )
X ( erg "1e-7 J" "Erg" )
X ( cal "4.1868 J" "International Table Calorie" )
X ( Btu "1055.05585262 J" "International Table Btu" )
X ( eV "1.6021892e-19 J" "Electron volt" )
X ( therm "105506000 J" "EEC therm" )
X
X ;; Power
X ( W "J/s" "*Watt" )
X ( hp "745.7 W" "Horsepower" )
X
X ;; Temperature
X ( K nil "*Degree Kelvin" K )
X ( dK "K" "Degree Kelvin" K )
X ( degK "K" "Degree Kelvin" K )
X ( dC "K" "Degree Celsius" C )
X ( degC "K" "Degree Celsius" C )
X ( dF "(5/9) K" "Degree Fahrenheit" F )
X ( degF "(5/9) K" "Degree Fahrenheit" F )
X
X ;; Pressure
X ( Pa "N/m^2" "*Pascal" )
X ( bar "1e5 Pa" "Bar" )
X ( atm "101325 Pa" "Standard atmosphere" )
X ( torr "atm/760" "Torr" )
X ( mHg "1000 torr" "Meter of mercury" )
X ( inHg "25.4 mmHg" "Inch of mercury" )
X ( inH2O "248.84 Pa" "Inch of water" )
X ( psi "6894.75729317 Pa" "Pound per square inch" )
X
X ;; Viscosity
X ( P "0.1 Pa s" "*Poise" )
X ( St "1e-4 m^2/s" "Stokes" )
X
X ;; Electromagnetism
X ( A nil "*Ampere" )
X ( C "A s" "Coulomb" )
X ( Fdy "96487 C" "Faraday" )
X ( e "1.6021892e-19 C" "Elementary charge" )
X ( V "W/A" "Volt" )
X ( ohm "V/A" "Ohm" )
X ( mho "A/V" "Mho" )
X ( S "A/V" "Siemens" )
X ( F "C/V" "Farad" )
X ( H "Wb/A" "Henry" )
X ( T "Wb/m^2" "Tesla" )
X ( G "1e-4 T" "Gauss" )
X ( Wb "V s" "Weber" )
X
X ;; Luminous intensity
X ( cd nil "*Candela" )
X ( sb "1e4 cd/m^2" "Stilb" )
X ( lm "cd sr" "Lumen" )
X ( lx "lm/m^2" "Lux" )
X ( ph "1e4 lx" "Phot" )
X ( fc "10.76 lx" "Footcandle" )
X ( lam "1e4 lm/m^2" "Lambert" )
X ( flam "1.07639104e-3 lam" "Footlambert" )
X
X ;; Radioactivity
X ( Bq "1/s" "*Becquerel" )
X ( Ci "3.7e8 Bq" "Curie" )
X ( Gy "J/kg" "Gray" )
X ( Sv "Gy" "Sievert" )
X ( R "2.58e-4 C/kg" "Roentgen" )
X ( rd ".01 Sv" "Rad" )
X ( rem "rd" "Rem" )
X
X ;; Amount of substance
X ( mol nil "*Mole" )
X
X ;; Plane angle
X ( rad nil "*Radian" )
X ( circ "2 pi rad" "Full circle" )
X ( deg "circ/360" "Degree" )
X ( arcmin "deg/60" "Arc minute" )
X ( arcsec "arcmin/60" "Arc second" )
X ( grad "circ/400" "Grade" )
X
X ;; Solid angle
X ( sr nil "*Steradian" )
X
X ;; Other physical quantities (CRC chem & phys, 67th ed)
X ( h "6.626176e-34 J s" "*Planck's constant" )
X ( hbar "h / 2 pi" "Planck's constant" )
X ( mu0 "4 pi 1e-7 H/m" "Permeability of vacuum" )
X ( Grav "6.6720e-11 N m^2/kg^2" "Gravitational constant" )
X ( Nav "6.0222e23 / mol" "Avagadro's constant" )
X ( me "9.109534e-31 kg" "Electron rest mass" )
X ( mp "1.6726485e-27 kg" "Proton rest mass" )
X ( mn "1.6749543e-27 kg" "Neutron rest mass" )
X ( mu "1.883566e-28 kg" "Muon rest mass" )
X ( Ryd "1.097373177e7 / m" "Rydberg's constant" )
X ( k "Ryd / Nav" "Boltzmann's constant" )
X ( fsc "7.2973506e-3" "Fine structure constant" )
X ( mue "9.284832e-24 J/T" "Electron magnetic moment" )
X ( mup "1.4106171e-26 J/T" "Proton magnetic moment" )
X ( R0 "8.31441 J/mol K" "Molar gas constant" )
X ( V0 "22.4136 L/mol" "Standard volume of ideal gas" )
X))
X
X
X(defvar math-additional-units nil
X "*Additional units table for user-defined units.
XMust be formatted like math-standard-units.
XIf this is changed, be sure to set math-units-table to nil to ensure
Xthat the combined units table will be rebuilt.")
X
X(defvar math-unit-prefixes
X '( ( ?E (float 1 18) "Exa" )
X ( ?P (float 1 15) "Peta" )
X ( ?T (float 1 12) "Tera" )
X ( ?G (float 1 9) "Giga" )
X ( ?M (float 1 6) "Mega" )
X ( ?k (float 1 3) "Kilo" )
X ( ?K (float 1 3) "Kilo" )
X ( ?h (float 1 2) "Hecto" )
X ( ?H (float 1 2) "Hecto" )
X ( ?D (float 1 1) "Deka" )
X ( ?d (float 1 -1) "Deci" )
X ( ?c (float 1 -2) "Centi" )
X ( ?m (float 1 -3) "Milli" )
X ( ?u (float 1 -6) "Micro" )
X ( ?n (float 1 -9) "Nano" )
X ( ?p (float 1 -12) "Pico" )
X ( ?f (float 1 -15) "Femto" )
X ( ?a (float 1 -18) "Atto" )
X))
X
X(defvar math-standard-units-systems
X '( ( base nil )
X ( si ( ( g '(* (var kg var-kg) (float 1 -3)) ) ) )
X ( mks ( ( g '(* (var kg var-kg) (float 1 -3)) ) ) )
X ( cgs ( ( m '(* (var cm var-cm) 100 ) ) ) )
X))
X
X(defvar math-units-table nil
X "Internal units table derived from math-defined-units.
XEntries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).")
X
X(defvar math-units-table-buffer-valid nil)
X
X
X(defun math-build-units-table ()
X (or math-units-table
X (let* ((combined-units (append math-additional-units
X math-standard-units))
X (unit-list (mapcar 'car combined-units))
X (calc-language nil)
X (math-expr-opers math-standard-opers)
X tab)
X (message "Building units table...")
X (setq math-units-table-buffer-valid nil)
X (setq tab (mapcar (function
X (lambda (x)
X (list (car x)
X (and (nth 1 x)
X (if (stringp (nth 1 x))
X (let ((exp (math-read-expr
X (nth 1 x))))
X (if (eq (car-safe exp) 'error)
X (error "Format error in definition of %s in units table: %s"
X (car x) (nth 2 exp))
X exp))
X (nth 1 x)))
X (nth 2 x)
X (nth 3 x)
X (and (not (nth 1 x))
X (list (cons (car x) 1))))))
X combined-units))
X (let ((math-units-table tab))
X (mapcar 'math-find-base-units tab))
X (message "Building units table...done")
X (setq math-units-table tab)))
X)
X
X(defun math-find-base-units (entry)
X (if (eq (nth 4 entry) 'boom)
X (error "Circular definition involving unit %s" (car entry)))
X (or (nth 4 entry)
X (let (base)
X (setcar (nthcdr 4 entry) 'boom)
X (math-find-base-units-rec (nth 1 entry) 1)
X '(or base
X (error "Dimensionless definition for unit %s" (car entry)))
X (while (eq (cdr (car base)) 0)
X (setq base (cdr base)))
X (let ((b base))
X (while (cdr b)
X (if (eq (cdr (car (cdr b))) 0)
X (setcdr b (cdr (cdr b)))
X (setq b (cdr b)))))
X (setq base (sort base 'math-compare-unit-names))
X (setcar (nthcdr 4 entry) base)
X base))
X)
X
X(defun math-compare-unit-names (a b)
X (memq (car b) (cdr (memq (car a) unit-list)))
X)
X
X(defun math-find-base-units-rec (expr pow)
X (let ((u (math-check-unit-name expr)))
X (cond (u
X (let ((ulist (math-find-base-units u)))
X (while ulist
X (let ((p (* (cdr (car ulist)) pow))
X (old (assq (car (car ulist)) base)))
X (if old
X (setcdr old (+ (cdr old) p))
X (setq base (cons (cons (car (car ulist)) p) base))))
X (setq ulist (cdr ulist)))))
X ((math-scalarp expr))
X ((and (eq (car expr) '^)
X (integerp (nth 2 expr)))
X (math-find-base-units-rec (nth 1 expr) (* pow (nth 2 expr))))
X ((eq (car expr) '*)
X (math-find-base-units-rec (nth 1 expr) pow)
X (math-find-base-units-rec (nth 2 expr) pow))
X ((eq (car expr) '/)
X (math-find-base-units-rec (nth 1 expr) pow)
X (math-find-base-units-rec (nth 2 expr) (- pow)))
X ((eq (car expr) 'neg)
X (math-find-base-units-rec (nth 1 expr) pow))
X ((eq (car expr) 'var)
X (or (eq (nth 1 expr) 'pi)
X (error "Unknown name %s in defining expression for unit %s"
X (nth 1 expr) (car entry))))
X (t (error "Malformed defining expression for unit %s" (car entry)))))
X)
X
X
X(defun math-units-in-expr-p (expr sub-exprs)
X (and (consp expr)
X (if (eq (car expr) 'var)
X (math-check-unit-name expr)
X (and (or sub-exprs
X (memq (car expr) '(* / ^)))
X (or (math-units-in-expr-p (nth 1 expr) sub-exprs)
X (math-units-in-expr-p (nth 2 expr) sub-exprs)))))
X)
X
X(defun math-only-units-in-expr-p (expr)
X (and (consp expr)
X (if (eq (car expr) 'var)
X (math-check-unit-name expr)
X (if (memq (car expr) '(* /))
X (and (math-only-units-in-expr-p (nth 1 expr))
X (math-only-units-in-expr-p (nth 2 expr)))
X (and (eq (car expr) '^)
X (and (math-only-units-in-expr-p (nth 1 expr))
X (math-realp (nth 2 expr)))))))
X)
X
X(defun math-single-units-in-expr-p (expr)
X (cond ((math-scalarp expr) nil)
X ((eq (car expr) 'var)
X (math-check-unit-name expr))
X ((eq (car expr) '*)
X (let ((u1 (math-single-units-in-expr-p (nth 1 expr)))
X (u2 (math-single-units-in-expr-p (nth 2 expr))))
X (or (and u1 u2 'wrong)
X u1
X u2)))
X ((eq (car expr) '/)
X (if (math-units-in-expr-p (nth 2 expr))
X 'wrong
X (math-single-units-in-expr-p (nth 1 expr))))
X (t 'wrong))
X)
X
X(defun math-check-unit-name (v)
X (and (eq (car-safe v) 'var)
X (or (assq (nth 1 v) (or math-units-table (math-build-units-table)))
X (let ((name (symbol-name (nth 1 v))))
X (and (> (length name) 1)
X (assq (aref name 0) math-unit-prefixes)
X (or (assq (intern (substring name 1)) math-units-table)
X (and (eq (aref name 0) ?M)
X (> (length name) 3)
X (eq (aref name 1) ?e)
X (eq (aref name 2) ?g)
X (assq (intern (substring name 3))
X math-units-table)))))))
X)
X
X
X(defun math-to-standard-units (expr which-standard)
X (math-to-standard-rec expr)
X)
X
X(defun math-to-standard-rec (expr)
X (if (eq (car-safe expr) 'var)
X (let ((u (math-check-unit-name expr))
X (base (nth 1 expr)))
X (if u
X (progn
X (if (nth 1 u)
X (setq expr (math-to-standard-rec (nth 1 u)))
X (let ((st (assq (car u) which-standard)))
X (if st
X (setq expr (nth 1 st))
X (setq expr (list 'var (car u)
X (intern (concat "var-"
X (symbol-name
X (car u)))))))))
X (or (null u)
X (eq base (car u))
X (setq expr (list '*
X (nth 1 (assq (aref (symbol-name base) 0)
X math-unit-prefixes))
X expr)))
X expr)
X (if (eq base 'pi)
X (math-pi)
X expr)))
X (if (Math-primp expr)
X expr
X (cons (car expr)
X (mapcar 'math-to-standard-rec (cdr expr)))))
X)
X
X(defun math-convert-units (expr new-units)
X (if (math-units-in-expr-p expr t)
X (math-convert-units-rec expr)
X (list '*
X (math-to-standard-units (list '/ expr new-units) nil)
X new-units))
X)
X
X(defun math-convert-units-rec (expr)
X (if (math-units-in-expr-p expr nil)
X (list '*
X (math-to-standard-units (list '/ expr new-units) nil)
X new-units)
X (if (Math-primp expr)
X expr
X (cons (car expr)
X (mapcar 'math-convert-units-rec (cdr expr)))))
X)
X
X(defun math-convert-temperature (expr old new)
X (let* ((units (math-single-units-in-expr-p expr))
X (uold (if old
X (if (or (null units)
X (equal (nth 1 old) (car units)))
X (math-check-unit-name old)
X (error "Inconsistent temperature units"))
X units))
X (unew (math-check-unit-name new)))
X (or (and (consp unew) (nth 3 unew))
X (error "Not a valid temperature unit"))
X (or (and (consp uold) (nth 3 uold))
X (error "Not a pure temperature expression"))
X (let ((v (car uold)))
X (setq expr (list '/ expr (list 'var v
X (intern (concat "var-"
X (symbol-name v)))))))
X (or (eq (nth 3 uold) (nth 3 unew))
X (cond ((eq (nth 3 uold) 'K)
X (setq expr (list '- expr '(float 27315 -2)))
X (if (eq (nth 3 unew) 'F)
X (setq expr (list '+ (list '* expr '(frac 9 5)) 32))))
X ((eq (nth 3 uold) 'C)
X (if (eq (nth 3 unew) 'F)
X (setq expr (list '+ (list '* expr '(frac 9 5)) 32))
X (setq expr (list '+ expr '(float 27315 -2)))))
X (t
X (setq expr (list '* (list '- expr 32) '(frac 5 9)))
X (if (eq (nth 3 unew) 'K)
X (setq expr (list '+ expr '(float 27315 -2)))))))
X (list '* expr new))
X)
X
X
X(setq math-simplifying-units nil)
X
X(defun math-simplify-units (a)
X (let ((math-simplifying-units t))
X (math-simplify a))
X)
X
X(math-defsimplify (+ -)
X (and math-simplifying-units
X (math-units-in-expr-p (nth 1 expr) nil)
X (let* ((units (math-extract-units (nth 1 expr)))
X (ratio (math-simplify (math-to-standard-units
X (list '/ (nth 2 expr) units) nil))))
X (if (math-units-in-expr-p ratio nil)
X (progn
X (calc-record-why "Inconsistent units" expr)
X expr)
X (list '* (math-add (math-remove-units (nth 1 expr)) ratio)
X units))))
X)
X
X(math-defsimplify /
X (and math-simplifying-units
X (let ((np (cdr expr))
X n nn)
X (while (eq (car-safe (setq n (car np))) '*)
X (math-simplify-units-divisor (cdr n) (cdr (cdr expr)))
X (setq np (cdr (cdr n))))
X (math-simplify-units-divisor np (cdr (cdr expr)))
X expr))
X)
X
X(defun math-simplify-units-divisor (np dp)
X (let ((n (car np))
X d dd temp)
X (while (eq (car-safe (setq d (car dp))) '*)
X (if (setq temp (math-simplify-units-quotient n (nth 1 d)))
X (progn
X (setcar np (setq n temp))
X (setcar (cdr d) 1)))
X (setq dp (cdr (cdr d))))
X (if (setq temp (math-simplify-units-quotient n d))
X (progn
X (setcar np (setq n temp))
X (setcar dp 1))))
X)
X
X;; Simplify, e.g., "in / cm" to "2.54" in a units expression.
X(defun math-simplify-units-quotient (n d)
X (let ((un (math-check-unit-name n))
X (ud (math-check-unit-name d)))
X (and un ud
X (equal (nth 4 un) (nth 4 ud))
X (math-to-standard-units (list '/ n d) nil)))
X)
X
X(math-defsimplify ^
X (and math-simplifying-units
X (math-realp (nth 2 expr))
X (math-simplify-units-pow (nth 1 expr) (nth 2 expr)))
X)
X
X(math-defsimplify calcFunc-sqrt
X (and math-simplifying-units
X (if (memq (car-safe (nth 1 expr)) '(* /))
X (list (car (nth 1 expr))
X (list 'calcFunc-sqrt (nth 1 (nth 1 expr)))
X (list 'calcFunc-sqrt (nth 2 (nth 1 expr))))
X (math-simplify-units-pow (nth 1 expr) '(frac 1 2))))
X)
X
X(math-defsimplify (calcFunc-floor
X calcFunc-ceil
X calcFunc-round
X calcFunc-trunc
X calcFunc-float
X calcFunc-frac
X calcFunc-abs
X calcFunc-clean)
X (and math-simplifying-units
X (if (math-only-units-in-expr-p (nth 1 expr))
X (nth 1 expr)
X (if (and (memq (car-safe (nth 1 expr)) '(* /))
X (or (math-only-units-in-expr-p
X (nth 1 (nth 1 expr)))
X (math-only-units-in-expr-p
X (nth 2 (nth 1 expr)))))
X (list (car (nth 1 expr))
X (cons (car expr)
X (cons (nth 1 (nth 1 expr))
X (cdr (cdr expr))))
X (cons (car expr)
X (cons (nth 2 (nth 1 expr))
X (cdr (cdr expr)))))))))
X
X(defun math-simplify-units-pow (a pow)
X (if (and (eq (car-safe a) '^)
X (math-check-unit-name (nth 1 a))
X (math-realp (nth 2 a)))
X (list '^ (nth 1 a) (math-mul pow (nth 2 a)))
X (let* ((u (math-check-unit-name a))
X (pf (math-to-simple-fraction pow))
X (d (and (eq (car-safe pf) 'frac) (nth 2 pf))))
X (and u
X (eq (car-safe pow) 'frac)
X (math-units-are-multiple u d)
X (list '^ (math-to-standard-units a nil) pow))))
X)
X
X(defun math-to-simple-fraction (f)
X (or (and (eq (car-safe f) 'float)
X (or (and (>= (nth 2 f) 0)
X (math-scale-int (nth 1 f) (nth 2 f)))
X (and (integerp (nth 1 f))
X (> (nth 1 f) -1000)
X (< (nth 1 f) 1000)
X (math-make-frac (nth 1 f)
X (math-scale-int 1 (- (nth 2 f)))))))
X f)
X)
X
X(defun math-units-are-multiple (u n)
X (setq u (nth 4 u))
X (while (and u (= (% (cdr (car u)) n) 0))
X (setq u (cdr u)))
X (null u)
X)
X
X(math-defsimplify calcFunc-sin
X (and math-simplifying-units
X (math-units-in-expr-p (nth 1 expr) nil)
X (let ((rad (math-simplify-units
X (math-evaluate-expr
X (math-to-standard-units (nth 1 expr) nil))))
X (calc-angle-mode 'rad))
X (and (eq (car-safe rad) '*)
X (Math-realp (nth 1 rad))
X (eq (car-safe (nth 2 rad)) 'var)
X (eq (nth 1 (nth 2 rad)) 'rad)
X (list 'calcFunc-sin (nth 1 rad)))))
X)
X
X(math-defsimplify calcFunc-cos
X (and math-simplifying-units
X (math-units-in-expr-p (nth 1 expr) nil)
X (let ((rad (math-simplify-units
X (math-evaluate-expr
X (math-to-standard-units (nth 1 expr) nil))))
X (calc-angle-mode 'rad))
X (and (eq (car-safe rad) '*)
X (Math-realp (nth 1 rad))
X (eq (car-safe (nth 2 rad)) 'var)
X (eq (nth 1 (nth 2 rad)) 'rad)
X (list 'calcFunc-cos (nth 1 rad)))))
X)
X
X(math-defsimplify calcFunc-tan
X (and math-simplifying-units
X (math-units-in-expr-p (nth 1 expr) nil)
X (let ((rad (math-simplify-units
X (math-evaluate-expr
X (math-to-standard-units (nth 1 expr) nil))))
X (calc-angle-mode 'rad))
X (and (eq (car-safe rad) '*)
X (Math-realp (nth 1 rad))
X (eq (car-safe (nth 2 rad)) 'var)
X (eq (nth 1 (nth 2 rad)) 'rad)
X (list 'calcFunc-tan (nth 1 rad)))))
X)
X
X
X(defun math-remove-units (expr)
X (if (math-check-unit-name expr)
X 1
X (if (Math-primp expr)
X expr
X (cons (car expr)
X (mapcar 'math-remove-units (cdr expr)))))
X)
X
X(defun math-extract-units (expr)
X (if (memq (car-safe expr) '(* /))
X (cons (car expr)
X (mapcar 'math-extract-units (cdr expr)))
X (if (math-check-unit-name expr) expr 1))
X)
X
X(defun math-build-units-table-buffer (enter-buffer)
X (if (not (and math-units-table math-units-table-buffer-valid
X (get-buffer "*Units Table*")))
X (let ((buf (get-buffer-create "*Units Table*"))
X (uptr (math-build-units-table))
X (calc-language (if (eq calc-language 'big) nil calc-language))
X (calc-float-format '(float 0))
X (calc-group-digits nil)
X (calc-number-radix 10)
X (calc-point-char ".")
X (std nil)
X u name shadowed)
X (save-excursion
X (message "Formatting units table...")
X (set-buffer buf)
X (setq buffer-read-only nil)
X (erase-buffer)
X (insert "Calculator Units Table:\n\n")
X (insert "Unit Type Definition Description\n\n")
X (while uptr
X (setq u (car uptr)
X name (nth 2 u))
X (if (eq (car u) 'm)
X (setq std t))
X (setq shadowed (and std (assq (car u) math-additional-units)))
X (if (and name
X (> (length name) 1)
X (eq (aref name 0) ?\*))
X (progn
X (or (eq uptr math-units-table)
X (insert "\n"))
X (setq name (substring name 1))))
X (insert " ")
X (and shadowed (insert "("))
X (insert (symbol-name (car u)))
X (and shadowed (insert ")"))
X (if (nth 3 u)
X (progn
X (indent-to 10)
X (insert (symbol-name (nth 3 u))))
X (or std
X (progn
X (indent-to 10)
X (insert "U"))))
X (indent-to 14)
X (and shadowed (insert "("))
X (if (nth 1 u)
X (insert (math-format-value (nth 1 u) 80))
X (insert (symbol-name (car u))))
X (and shadowed (insert ")"))
X (indent-to 42)
X (if name
X (insert name))
X (if shadowed
X (insert " (redefined above)")
X (or (nth 1 u)
X (insert " (base unit)")))
X (insert "\n")
X (setq uptr (cdr uptr)))
X (insert "\n\nUnit Prefix Table:\n\n")
X (setq uptr math-unit-prefixes)
X (while uptr
X (setq u (car uptr))
X (insert " " (char-to-string (car u)))
X (if (equal (nth 1 u) (nth 1 (nth 1 uptr)))
X (insert " " (char-to-string (car (car (setq uptr (cdr uptr)))))
X " ")
X (insert " "))
X (insert "10^" (int-to-string (nth 2 (nth 1 u))))
X (indent-to 15)
X (insert " " (nth 2 u) "\n")
X (setq uptr (cdr uptr)))
X (insert "\n")
X (setq buffer-read-only t)
X (message "Formatting units table...done"))
X (setq math-units-table-buffer-valid t)
X (let ((oldbuf (current-buffer)))
X (set-buffer buf)
X (goto-char (point-min))
X (set-buffer oldbuf))
X (if enter-buffer
X (pop-to-buffer buf)
X (display-buffer buf)))
X (if enter-buffer
X (pop-to-buffer (get-buffer "*Units Table*"))
X (display-buffer (get-buffer "*Units Table*"))))
X)
X
X
X
X
X;;;; User-programmability.
X
X;;; Compiling Lisp-like forms to use the math library.
X
X(defun math-do-defmath (func args body)
X (let* ((fname (intern (concat "calcFunc-" (symbol-name func))))
X (doc (if (stringp (car body)) (list (car body))))
X (clargs (mapcar 'math-clean-arg args))
X (body (math-define-function-body
X (if (stringp (car body)) (cdr body) body)
X clargs)))
X (list 'progn
X (if (and (consp (car body))
X (eq (car (car body)) 'interactive))
X (let ((inter (car body)))
X (setq body (cdr body))
X (if (or (> (length inter) 2)
X (integerp (nth 1 inter)))
X (let ((hasprefix nil) (hasmulti nil))
X (if (stringp (nth 1 inter))
X (progn
X (cond ((equal (nth 1 inter) "p")
X (setq hasprefix t))
X ((equal (nth 1 inter) "m")
X (setq hasmulti t))
X (t (error
X "Can't handle interactive code string \"%s\""
X (nth 1 inter))))
X (setq inter (cdr inter))))
X (if (not (integerp (nth 1 inter)))
X (error
X "Expected an integer in interactive specification"))
X (append (list 'defun
X (intern (concat "calc-"
X (symbol-name func)))
X (if (or hasprefix hasmulti)
X '(&optional n)
X ()))
X doc
X (if (or hasprefix hasmulti)
X '((interactive "P"))
X '((interactive)))
X (list
X (append
X '(calc-slow-wrapper)
X (and hasmulti
X (list
X (list 'setq
X 'n
X (list 'if
X 'n
X (list 'prefix-numeric-value
X 'n)
X (nth 1 inter)))))
X (list
X (list 'calc-enter-result
X (if hasmulti 'n (nth 1 inter))
X (nth 2 inter)
X (if hasprefix
X (list 'append
X (list 'quote (list fname))
X (list 'calc-top-list-n
X (nth 1 inter))
X (list 'and
X 'n
X (list
X 'list
X (list
X 'math-normalize
X (list
X 'prefix-numeric-value
X 'n)))))
X (list 'cons
X (list 'quote fname)
X (list 'calc-top-list-n
X (if hasmulti
X 'n
X (nth 1 inter)))))))))))
X (append (list 'defun
X (intern (concat "calc-" (symbol-name func)))
X args)
X doc
X (list
X inter
X (cons 'calc-wrapper body))))))
X (append (list 'defun fname clargs)
X doc
X (math-do-arg-list-check args nil nil)
X body)))
X)
X
X(defun math-clean-arg (arg)
X (if (consp arg)
X (math-clean-arg (nth 1 arg))
X arg)
X)
X
X(defun math-do-arg-check (arg var is-opt is-rest)
X (if is-opt
X (let ((chk (math-do-arg-check arg var nil nil)))
X (list (cons 'and
X (cons var
X (if (cdr chk)
X (setq chk (list (cons 'progn chk)))
X chk)))))
X (and (consp arg)
X (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
X (qual (car arg))
X (qqual (list 'quote qual))
X (qual-name (symbol-name qual))
X (chk (intern (concat "math-check-" qual-name))))
X (if (fboundp chk)
X (append rest
X (list
X (if is-rest
X (list 'setq var
X (list 'mapcar (list 'quote chk) var))
X (list 'setq var (list chk var)))))
X (if (fboundp (setq chk (intern (concat "math-" qual-name))))
X (append rest
X (list
X (if is-rest
X (list 'mapcar
X (list 'function
X (list 'lambda '(x)
X (list 'or
X (list chk 'x)
X (list 'math-reject-arg
X 'x qqual))))
X var)
X (list 'or
X (list chk var)
X (list 'math-reject-arg var qqual)))))
X (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
X (fboundp (setq chk (intern
X (concat "math-"
X (math-match-substring
X qual-name 1))))))
X (append rest
X (list
X (if is-rest
X (list 'mapcar
X (list 'function
X (list 'lambda '(x)
X (list 'and
X (list chk 'x)
X (list 'math-reject-arg
X 'x qqual))))
X var)
X (list 'and
X (list chk var)
X (list 'math-reject-arg var qqual)))))
X (error "Unknown qualifier `%s'" qual-name)))))))
X)
X
X(defun math-do-arg-list-check (args is-opt is-rest)
X (cond ((null args) nil)
X ((consp (car args))
X (append (math-do-arg-check (car args)
X (math-clean-arg (car args))
X is-opt is-rest)
X (math-do-arg-list-check (cdr args) is-opt is-rest)))
X ((eq (car args) '&optional)
X (math-do-arg-list-check (cdr args) t nil))
X ((eq (car args) '&rest)
X (math-do-arg-list-check (cdr args) nil t))
X (t (math-do-arg-list-check (cdr args) is-opt is-rest)))
X)
X
X(defconst math-prim-funcs
X '( (~= . math-nearly-equal)
X (% . math-mod)
X (lsh . math-lshift-binary)
X (ash . math-shift-binary)
X (logand . math-and)
X (logandc2 . math-diff)
X (logior . math-or)
X (logxor . math-xor)
X (lognot . math-not)
X (equal . equal) ; need to leave these ones alone!
X (eq . eq)
X (and . and)
X (or . or)
X (if . if)
X (^ . math-pow)
X (expt . math-pow)
X )
X)
X
X(defconst math-prim-vars
X '( (nil . nil)
X (t . t)
X (&optional . &optional)
X (&rest . &rest)
X )
X)
X
X(defun math-define-function-body (body env)
X (let ((body (math-define-body body env)))
X (if (math-body-refers-to body 'math-return)
X (list (cons 'catch (cons '(quote math-return) body)))
X body))
X)
X
X(defun math-define-body (body exp-env)
X (math-define-list body)
X)
X
X(defun math-define-list (body &optional quote)
X (cond ((null body)
X nil)
X ((and (eq (car body) ':)
X (stringp (nth 1 body)))
X (cons (let* ((math-read-expr-quotes t)
X (calc-language nil)
X (math-expr-opers math-standard-opers)
X (exp (math-read-expr (nth 1 body))))
X (if (eq (car exp) 'error)
X (error "Bad format: %s" (nth 1 body))
X (math-define-exp exp)))
X (math-define-list (cdr (cdr body)))))
X (quote
X (cons (cond ((consp (car body))
X (math-define-list (cdr body) t))
X (t
X (car body)))
X (math-define-list (cdr body))))
X (t
X (cons (math-define-exp (car body))
X (math-define-list (cdr body)))))
X)
X
X(defun math-define-exp (exp)
X (cond ((consp exp)
X (let ((func (car exp)))
X (cond ((memq func '(quote function))
X (if (and (consp (nth 1 exp))
X (eq (car (nth 1 exp)) 'lambda))
X (cons 'quote
X (math-define-lambda (nth 1 exp) exp-env))
X exp))
X ((memq func '(let let* for foreach))
X (let ((head (nth 1 exp))
X (body (cdr (cdr exp))))
X (if (memq func '(let let*))
X ()
X (setq func (cdr (assq func '((for . math-for)
X (foreach . math-foreach)))))
X (if (not (listp (car head)))
X (setq head (list head))))
X (macroexpand
X (cons func
X (cons (math-define-let head)
X (math-define-body body
X (nconc
X (math-define-let-env head)
X exp-env)))))))
X ((and (memq func '(setq setf))
X (math-complicated-lhs (cdr exp)))
X (if (> (length exp) 3)
X (cons 'progn (math-define-setf-list (cdr exp)))
X (math-define-setf (nth 1 exp) (nth 2 exp))))
X ((eq func 'condition-case)
X (cons func
X (cons (nth 1 exp)
X (math-define-body (cdr (cdr exp))
X (cons (nth 1 exp)
X exp-env)))))
X ((eq func 'cond)
X (cons func
X (math-define-cond (cdr exp))))
X ((and (consp func) ; ('spam a b) == force use of plain spam
X (eq (car func) 'quote))
X (cons func (math-define-list (cdr exp))))
X ((symbolp func)
X (let ((args (math-define-list (cdr exp)))
X (prim (assq func math-prim-funcs)))
X (cond (prim
X (cons (cdr prim) args))
X ((eq func 'floatp)
X (list 'eq (car args) '(quote float)))
X ((eq func '+)
X (math-define-binop 'math-add 0
X (car args) (cdr args)))
X ((eq func '-)
X (if (= (length args) 1)
X (cons 'math-neg args)
X (math-define-binop 'math-sub 0
X (car args) (cdr args))))
X ((eq func '*)
X (math-define-binop 'math-mul 1
X (car args) (cdr args)))
X ((eq func '/)
X (math-define-binop 'math-div 1
X (car args) (cdr args)))
X ((eq func 'min)
X (math-define-binop 'math-min 0
X (car args) (cdr args)))
X ((eq func 'max)
X (math-define-binop 'math-max 0
X (car args) (cdr args)))
X ((eq func '<)
X (if (and (math-numberp (nth 1 args))
X (math-zerop (nth 1 args)))
X (list 'math-posp (car args))
X (cons 'math-lessp args)))
X ((eq func '>)
X (if (and (math-numberp (nth 1 args))
X (math-zerop (nth 1 args)))
X (list 'math-posp (car args))
X (list 'math-lessp (nth 1 args) (nth 0 args))))
X ((eq func '<=)
X (list 'not
X (if (and (math-numberp (nth 1 args))
X (math-zerop (nth 1 args)))
X (list 'math-posp (car args))
X (cons 'math-lessp args))))
X ((eq func '>=)
X (list 'not
X (if (and (math-numberp (nth 1 args))
X (math-zerop (nth 1 args)))
X (list 'math-negp (car args))
X (list 'math-lessp
X (nth 1 args) (nth 0 args)))))
X ((eq func '=)
X (if (and (math-numberp (nth 1 args))
X (math-zerop (nth 1 args)))
X (list 'math-zerop (nth 0 args))
X (if (and (integerp (nth 1 args))
X (/= (% (nth 1 args) 10) 0))
X (cons 'math-equal-int args)
X (cons 'math-equal args))))
X ((eq func '/=)
X (list 'not
X (if (and (math-numberp (nth 1 args))
X (math-zerop (nth 1 args)))
X (list 'math-zerop (nth 0 args))
X (if (and (integerp (nth 1 args))
X (/= (% (nth 1 args) 10) 0))
X (cons 'math-equal-int args)
X (cons 'math-equal args)))))
X ((eq func '1+)
X (list 'math-add (car args) 1))
X ((eq func '1-)
X (list 'math-add (car args) -1))
X ((eq func 'not) ; optimize (not (not x)) => x
X (if (eq (car-safe args) func)
X (car (nth 1 args))
X (cons func args)))
X ((and (eq func 'elt) (cdr (cdr args)))
X (math-define-elt (car args) (cdr args)))
X (t
X (macroexpand
X (let* ((name (symbol-name func))
X (cfunc (intern (concat "calcFunc-" name)))
X (mfunc (intern (concat "math-" name))))
X (cond ((fboundp cfunc)
X (cons cfunc args))
X ((fboundp mfunc)
X (cons mfunc args))
X ((or (fboundp func)
X (string-match "\\`calcFunc-.*" name))
X (cons func args))
X (t
X (cons cfunc args)))))))))
X (t (cons func args)))))
X ((symbolp exp)
X (let ((prim (assq exp math-prim-vars))
X (name (symbol-name exp)))
X (cond (prim
X (cdr prim))
X ((memq exp exp-env)
X exp)
X ((string-match "-" name)
SHAR_EOF
echo "End of part 10"
echo "File calc-ext.el is continued in part 11"
echo "11" > s2_seq_.tmp
exit 0