Usenet 1994 October

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume13 / gmcalc / part10 < prev next >

Wrap

Text File | 1990-06-05 | 57.1 KB | 1,896 lines

Newsgroups: comp.sources.misc From: daveg@csvax.caltech.edu (David Gillespie) Subject: v13i036: Emacs Calculator 1.01, part 10/19 Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) 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