daveg@csvax.caltech.edu (David Gillespie) (06/06/90)
Posting-number: Volume 13, Issue 35
Submitted-by: daveg@csvax.caltech.edu (David Gillespie)
Archive-name: gmcalc/part09
---- Cut Here and unpack ----
#!/bin/sh
# this is part 9 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc-ext.el continued
#
CurArch=9
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 1153 1163 1171 1181 1187 1193 1201 1213 1217 1223 1229 1231 1237 1249
X 1259 1277 1279 1283 1289 1291 1297 1301 1303 1307 1319 1321 1327 1361
X 1367 1373 1381 1399 1409 1423 1427 1429 1433 1439 1447 1451 1453 1459
X 1471 1481 1483 1487 1489 1493 1499 1511 1523 1531 1543 1549 1553 1559
X 1567 1571 1579 1583 1597 1601 1607 1609 1613 1619 1621 1627 1637 1657
X 1663 1667 1669 1693 1697 1699 1709 1721 1723 1733 1741 1747 1753 1759
X 1777 1783 1787 1789 1801 1811 1823 1831 1847 1861 1867 1871 1873 1877
X 1879 1889 1901 1907 1913 1931 1933 1949 1951 1973 1979 1987 1993 1997
X 1999 2003 2011 2017 2027 2029 2039 2053 2063 2069 2081 2083 2087 2089
X 2099 2111 2113 2129 2131 2137 2141 2143 2153 2161 2179 2203 2207 2213
X 2221 2237 2239 2243 2251 2267 2269 2273 2281 2287 2293 2297 2309 2311
X 2333 2339 2341 2347 2351 2357 2371 2377 2381 2383 2389 2393 2399 2411
X 2417 2423 2437 2441 2447 2459 2467 2473 2477 2503 2521 2531 2539 2543
X 2549 2551 2557 2579 2591 2593 2609 2617 2621 2633 2647 2657 2659 2663
X 2671 2677 2683 2687 2689 2693 2699 2707 2711 2713 2719 2729 2731 2741
X 2749 2753 2767 2777 2789 2791 2797 2801 2803 2819 2833 2837 2843 2851
X 2857 2861 2879 2887 2897 2903 2909 2917 2927 2939 2953 2957 2963 2969
X 2971 2999 3001 3011 3019 3023 3037 3041 3049 3061 3067 3079 3083 3089
X 3109 3119 3121 3137 3163 3167 3169 3181 3187 3191 3203 3209 3217 3221
X 3229 3251 3253 3257 3259 3271 3299 3301 3307 3313 3319 3323 3329 3331
X 3343 3347 3359 3361 3371 3373 3389 3391 3407 3413 3433 3449 3457 3461
X 3463 3467 3469 3491 3499 3511 3517 3527 3529 3533 3539 3541 3547 3557
X 3559 3571 3581 3583 3593 3607 3613 3617 3623 3631 3637 3643 3659 3671
X 3673 3677 3691 3697 3701 3709 3719 3727 3733 3739 3761 3767 3769 3779
X 3793 3797 3803 3821 3823 3833 3847 3851 3853 3863 3877 3881 3889 3907
X 3911 3917 3919 3923 3929 3931 3943 3947 3967 3989 4001 4003 4007 4013
X 4019 4021 4027 4049 4051 4057 4073 4079 4091 4093 4099 4111 4127 4129
X 4133 4139 4153 4157 4159 4177 4201 4211 4217 4219 4229 4231 4241 4243
X 4253 4259 4261 4271 4273 4283 4289 4297 4327 4337 4339 4349 4357 4363
X 4373 4391 4397 4409 4421 4423 4441 4447 4451 4457 4463 4481 4483 4493
X 4507 4513 4517 4519 4523 4547 4549 4561 4567 4583 4591 4597 4603 4621
X 4637 4639 4643 4649 4651 4657 4663 4673 4679 4691 4703 4721 4723 4729
X 4733 4751 4759 4783 4787 4789 4793 4799 4801 4813 4817 4831 4861 4871
X 4877 4889 4903 4909 4919 4931 4933 4937 4943 4951 4957 4967 4969 4973
X 4987 4993 4999 5003])
X
X
X
X
X;;; Bitwise operations.
X
X(defun math-and (a b &optional w) ; [I I I] [Public]
X (cond ((Math-messy-integerp w)
X (math-and a b (math-trunc w)))
X ((and w (not (integerp w)))
X (math-reject-arg w 'integerp))
X ((and (integerp a) (integerp b))
X (math-clip (logand a b) w))
X ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod))
X (math-binary-modulo-args 'math-and a b w))
X ((not (Math-num-integerp a))
X (math-reject-arg a 'integerp))
X ((not (Math-num-integerp b))
X (math-reject-arg b 'integerp))
X (t (math-clip (cons 'bigpos
X (math-and-bignum (math-binary-arg a w)
X (math-binary-arg b w)))
X w)))
X)
X(fset 'calcFunc-and (symbol-function 'math-and))
X
X(defun math-binary-arg (a w)
X (if (not (Math-integerp a))
X (setq a (math-trunc a)))
X (if (Math-integer-negp a)
X (math-not-bignum (cdr (math-bignum-test (math-sub -1 a)))
X (math-abs (if w (math-trunc w) calc-word-size)))
X (cdr (Math-bignum-test a)))
X)
X
X(defun math-binary-modulo-args (f a b w)
X (let (mod)
X (if (eq (car-safe a) 'mod)
X (progn
X (setq mod (nth 2 a)
X a (nth 1 a))
X (if (eq (car-safe b) 'mod)
X (if (equal mod (nth 2 b))
X (setq b (nth 1 b))
X (math-reject-arg b "Inconsistent modulos"))))
X (setq mod (nth 2 b)
X b (nth 1 b)))
X (if (Math-messy-integerp mod)
X (setq mod (math-trunc mod))
X (or (Math-integerp mod)
X (math-reject-arg mod 'integerp)))
X (let ((bits (math-integer-log2 mod)))
X (if bits
X (if w
X (if (/= w bits)
X (calc-record-why
X "Warning: Modulo inconsistent with word size"))
X (setq w bits))
X (calc-record-why "Warning: Modulo is not a power of 2"))
X (math-make-mod (if b
X (funcall f a b w)
X (funcall f a w))
X mod)))
X)
X
X(defun math-and-bignum (a b) ; [l l l]
X (and a b
X (let ((qa (math-div-bignum-digit a 512))
X (qb (math-div-bignum-digit b 512)))
X (math-mul-bignum-digit (math-and-bignum (math-norm-bignum (car qa))
X (math-norm-bignum (car qb)))
X 512
X (logand (cdr qa) (cdr qb)))))
X)
X
X(defun math-or (a b &optional w) ; [I I I] [Public]
X (cond ((Math-messy-integerp w)
X (math-or a b (math-trunc w)))
X ((and w (not (integerp w)))
X (math-reject-arg w 'integerp))
X ((and (integerp a) (integerp b))
X (math-clip (logior a b) w))
X ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod))
X (math-binary-modulo-args 'math-or a b w))
X ((not (Math-num-integerp a))
X (math-reject-arg a 'integerp))
X ((not (Math-num-integerp b))
X (math-reject-arg b 'integerp))
X (t (math-clip (cons 'bigpos
X (math-or-bignum (math-binary-arg a w)
X (math-binary-arg b w)))
X w)))
X)
X(fset 'calcFunc-or (symbol-function 'math-or))
X
X(defun math-or-bignum (a b) ; [l l l]
X (and (or a b)
X (let ((qa (math-div-bignum-digit a 512))
X (qb (math-div-bignum-digit b 512)))
X (math-mul-bignum-digit (math-or-bignum (math-norm-bignum (car qa))
X (math-norm-bignum (car qb)))
X 512
X (logior (cdr qa) (cdr qb)))))
X)
X
X(defun math-xor (a b &optional w) ; [I I I] [Public]
X (cond ((Math-messy-integerp w)
X (math-xor a b (math-trunc w)))
X ((and w (not (integerp w)))
X (math-reject-arg w 'integerp))
X ((and (integerp a) (integerp b))
X (math-clip (logxor a b) w))
X ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod))
X (math-binary-modulo-args 'math-xor a b w))
X ((not (Math-num-integerp a))
X (math-reject-arg a 'integerp))
X ((not (Math-num-integerp b))
X (math-reject-arg b 'integerp))
X (t (math-clip (cons 'bigpos
X (math-xor-bignum (math-binary-arg a w)
X (math-binary-arg b w)))
X w)))
X)
X(fset 'calcFunc-xor (symbol-function 'math-xor))
X
X(defun math-xor-bignum (a b) ; [l l l]
X (and (or a b)
X (let ((qa (math-div-bignum-digit a 512))
X (qb (math-div-bignum-digit b 512)))
X (math-mul-bignum-digit (math-xor-bignum (math-norm-bignum (car qa))
X (math-norm-bignum (car qb)))
X 512
X (logxor (cdr qa) (cdr qb)))))
X)
X
X(defun math-diff (a b &optional w) ; [I I I] [Public]
X (cond ((Math-messy-integerp w)
X (math-diff a b (math-trunc w)))
X ((and w (not (integerp w)))
X (math-reject-arg w 'integerp))
X ((and (integerp a) (integerp b))
X (math-clip (logand a (lognot b)) w))
X ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod))
X (math-binary-modulo-args 'math-diff a b w))
X ((not (Math-num-integerp a))
X (math-reject-arg a 'integerp))
X ((not (Math-num-integerp b))
X (math-reject-arg b 'integerp))
X (t (math-clip (cons 'bigpos
X (math-diff-bignum (math-binary-arg a w)
X (math-binary-arg b w)))
X w)))
X)
X(fset 'calcFunc-diff (symbol-function 'math-diff))
X
X(defun math-diff-bignum (a b) ; [l l l]
X (and a
X (let ((qa (math-div-bignum-digit a 512))
X (qb (math-div-bignum-digit b 512)))
X (math-mul-bignum-digit (math-diff-bignum (math-norm-bignum (car qa))
X (math-norm-bignum (car qb)))
X 512
X (logand (cdr qa) (lognot (cdr qb))))))
X)
X
X(defun math-not (a &optional w) ; [I I] [Public]
X (cond ((Math-messy-integerp w)
X (math-not a (math-trunc w)))
X ((eq (car-safe a) 'mod)
X (math-binary-modulo-args 'math-not a nil w))
X ((and w (not (integerp w)))
X (math-reject-arg w 'integerp))
X ((not (Math-num-integerp a))
X (math-reject-arg a 'integerp))
X ((< (or w (setq w calc-word-size)) 0)
X (math-clip (math-not a (- w)) w))
X (t (math-normalize
X (cons 'bigpos
X (math-not-bignum (math-binary-arg a w)
X w)))))
X)
X(fset 'calcFunc-not (symbol-function 'math-not))
X
X(defun math-not-bignum (a w) ; [l l]
X (let ((q (math-div-bignum-digit a 512)))
X (if (<= w 9)
X (list (logand (lognot (cdr q))
X (1- (lsh 1 w))))
X (math-mul-bignum-digit (math-not-bignum (math-norm-bignum (car q))
X (- w 9))
X 512
X (logxor (cdr q) 511))))
X)
X
X(defun math-lshift-binary (a &optional n w) ; [I I] [Public]
X (setq a (math-trunc a)
X n (if n (math-trunc n) 1))
X (if (eq (car-safe a) 'mod)
X (math-binary-modulo-args 'math-lshift-binary a n w)
X (setq w (if w (math-trunc w) calc-word-size))
X (or (integerp w)
X (math-reject-arg w 'integerp))
X (or (Math-integerp a)
X (math-reject-arg a 'integerp))
X (or (Math-integerp n)
X (math-reject-arg n 'integerp))
X (if (< w 0)
X (math-clip (math-lshift-binary a n (- w)) w)
X (if (Math-integer-negp a)
X (setq a (math-clip a w)))
X (cond ((or (Math-lessp n (- w))
X (Math-lessp w n))
X 0)
X ((< n 0)
X (math-quotient (math-clip a w) (math-power-of-2 (- n))))
X (t
X (math-clip (math-mul a (math-power-of-2 n)) w)))))
X)
X(fset 'calcFunc-lsh (symbol-function 'math-lshift-binary))
X
X(defun math-rshift-binary (a &optional n w) ; [I I] [Public]
X (math-lshift-binary a (math-neg (or n 1)) w)
X)
X(fset 'calcFunc-rsh (symbol-function 'math-rshift-binary))
X
X(defun math-shift-binary (a &optional n w) ; [I I] [Public]
X (if (not (Math-negp n))
X (math-lshift-binary a n w)
X (setq a (math-trunc a)
X n (if n (math-trunc n) 1))
X (if (eq (car-safe a) 'mod)
X (math-binary-modulo-args 'math-shift-binary a n w)
X (setq w (if w (math-trunc w) calc-word-size))
X (or (integerp w)
X (math-reject-arg w 'integerp))
X (or (Math-integerp a)
X (math-reject-arg a 'integerp))
X (or (Math-integerp n)
X (math-reject-arg n 'integerp))
X (if (< w 0)
X (math-clip (math-shift-binary a n (- w)) w)
X (if (Math-integer-negp a)
X (setq a (math-clip a w)))
X (let ((two-to-sizem1 (math-power-of-2 (1- w)))
X (sh (math-lshift-binary a n w)))
X (cond ((Math-natnum-lessp a two-to-sizem1)
X sh)
X ((Math-lessp n (- 1 w))
X (math-add (math-mul two-to-sizem1 2) -1))
X (t (let ((two-to-n (math-power-of-2 (- n))))
X (math-add (math-lshift-binary (math-add two-to-n -1)
X (+ w n) w)
X sh))))))))
X)
X(fset 'calcFunc-ash (symbol-function 'math-shift-binary))
X
X(defun math-rotate-binary (a &optional n w) ; [I I] [Public]
X (setq a (math-trunc a)
X n (if n (math-trunc n) 1))
X (if (eq (car-safe a) 'mod)
X (math-binary-modulo-args 'math-rotate-binary a n w)
X (setq w (if w (math-trunc w) calc-word-size))
X (or (integerp w)
X (math-reject-arg w 'integerp))
X (or (Math-integerp a)
X (math-reject-arg a 'integerp))
X (or (Math-integerp n)
X (math-reject-arg n 'integerp))
X (if (< w 0)
X (math-clip (math-rotate-binary a n (- w)) w)
X (if (Math-integer-negp a)
X (setq a (math-clip a w)))
X (cond ((or (Math-integer-negp n)
X (not (Math-natnum-lessp n w)))
X (math-rotate-binary a (math-mod n w) w))
X (t
X (math-add (math-lshift-binary a (- n w) w)
X (math-lshift-binary a n w))))))
X)
X(fset 'calcFunc-rot (symbol-function 'math-rotate-binary))
X
X(defun math-clip (a &optional w) ; [I I] [Public]
X (cond ((Math-messy-integerp w)
X (math-clip a (math-trunc w)))
X ((eq (car-safe a) 'mod)
X (math-binary-modulo-args 'math-clip a nil w))
X ((and w (not (integerp w)))
X (math-reject-arg w 'integerp))
X ((not (Math-num-integerp a))
X (math-reject-arg a 'integerp))
X ((< (or w (setq w calc-word-size)) 0)
X (setq a (math-clip a (- w)))
X (if (Math-natnum-lessp a (math-power-of-2 (- -1 w)))
X a
X (math-sub a (math-power-of-2 (- w)))))
X ((Math-negp a)
X (math-normalize (cons 'bigpos (math-binary-arg a w))))
X ((and (integerp a) (< a 1000000))
X (if (>= w 20)
X a
X (logand a (1- (lsh 1 w)))))
X (t
X (math-normalize
X (cons 'bigpos
X (math-clip-bignum (cdr (math-bignum-test (math-trunc a)))
X w)))))
X)
X(fset 'calcFunc-clip (symbol-function 'math-clip))
X
X(defun math-clip-bignum (a w) ; [l l]
X (let ((q (math-div-bignum-digit a 512)))
X (if (<= w 9)
X (list (logand (cdr q)
X (1- (lsh 1 w))))
X (math-mul-bignum-digit (math-clip-bignum (math-norm-bignum (car q))
X (- w 9))
X 512
X (cdr q))))
X)
X
X
X
X;;;; Algebra.
X
X;;; Evaluate variables in an expression.
X(defun math-evaluate-expr (x) ; [Public]
X (math-normalize (math-evaluate-expr-rec x))
X)
X
X(defun math-evaluate-expr-rec (x)
X (if (consp x)
X (setq x (cons (car x)
X (mapcar 'math-evaluate-expr-rec (cdr x)))))
X (if (eq (car-safe x) 'var)
X (if (and (boundp (nth 2 x))
X (symbol-value (nth 2 x))
X (not (eq (car-safe (symbol-value (nth 2 x)))
X 'incomplete)))
X (let ((val (symbol-value (nth 2 x))))
X (if (eq (car-safe val) 'special-const)
X (if calc-symbolic-mode
X x
X val)
X val))
X x)
X x)
X)
X
X
X;;; Combine two terms being added, if possible.
X(defun math-combine-sum (a b nega negb scalar-okay)
X (if (and scalar-okay (Math-objvecp a) (Math-objvecp b))
X (math-add-or-sub a b nega negb)
X (let ((amult 1) (bmult 1))
X (and (consp a)
X (cond ((and (eq (car a) '*)
X (Math-numberp (nth 1 a)))
X (setq amult (nth 1 a)
X a (nth 2 a)))
X ((and (eq (car a) '/)
X (Math-numberp (nth 2 a)))
X (setq amult (if (Math-integerp (nth 2 a))
X (list 'frac 1 (nth 2 a))
X (math-div 1 (nth 2 a)))
X a (nth 1 a)))
X ((eq (car a) 'neg)
X (setq amult -1
X a (nth 1 a)))))
X (and (consp b)
X (cond ((and (eq (car b) '*)
X (Math-numberp (nth 1 b)))
X (setq bmult (nth 1 b)
X b (nth 2 b)))
X ((and (eq (car b) '/)
X (Math-numberp (nth 2 b)))
X (setq bmult (if (Math-integerp (nth 2 b))
X (list 'frac 1 (nth 2 b))
X (math-div 1 (nth 2 b)))
X b (nth 1 b)))
X ((eq (car b) 'neg)
X (setq bmult -1
X b (nth 1 b)))))
X (and (equal a b)
X (progn
X (if nega (setq amult (math-neg amult)))
X (if negb (setq bmult (math-neg bmult)))
X (setq amult (math-add amult bmult))
X (math-mul amult a)))))
X)
X
X(defun math-add-or-sub (a b aneg bneg)
X (if aneg (setq a (math-neg a)))
X (if bneg (setq b (math-neg b)))
X (math-add a b)
X)
X
X;;; The following is expanded out four ways for speed.
X(defun math-combine-prod (a b inva invb scalar-okay)
X (cond
X ((and scalar-okay (Math-objvecp a) (Math-objvecp b))
X (math-mul-or-div a b inva invb))
X ((and (eq (car-safe a) '^)
X inva
X (math-looks-negp (nth 2 a)))
X (math-mul (math-pow (nth 1 a) (math-neg (nth 2 a))) b))
X ((and (eq (car-safe b) '^)
X invb
X (math-looks-negp (nth 2 b)))
X (math-mul a (math-pow (nth 1 b) (math-neg (nth 2 b)))))
X (t (let ((apow 1) (bpow 1))
X (and (consp a)
X (cond ((and (eq (car a) '^)
X (or math-simplify-symbolic-powers
X (Math-numberp (nth 2 a))))
X (setq apow (nth 2 a)
X a (nth 1 a)))
X ((and (eq (car a) 'calcFunc-sqrt))
X (setq apow '(frac 1 2)
X a (nth 1 a)))))
X (and (consp b)
X (cond ((and (eq (car b) '^)
X (or math-simplify-symbolic-powers
X (Math-numberp (nth 2 b))))
X (setq bpow (nth 2 b)
X b (nth 1 b)))
X ((and (eq (car b) 'calcFunc-sqrt))
X (setq bpow '(frac 1 2)
X b (nth 1 b)))))
X (and (equal a b)
X (progn
X (if inva (setq apow (math-neg apow)))
X (if invb (setq bpow (math-neg bpow)))
X (setq apow (math-add apow bpow))
X (cond ((equal apow '(frac 1 2))
X (list 'calcFunc-sqrt a))
X ((equal apow '(frac -1 2))
X (math-div 1 (list 'calcFunc-sqrt a)))
X (t (math-pow a apow))))))))
X)
X(setq math-simplify-symbolic-powers nil)
X
X(defun math-mul-or-div (a b ainv binv)
X (if ainv
X (if binv
X (math-div (math-div 1 a) b)
X (math-div b a))
X (if binv
X (math-div a b)
X (math-mul a b)))
X)
X
X
X
X;;; True if A comes before B in a canonical ordering of expressions. [P X X]
X(defun math-beforep (a b) ; [Public]
X (cond ((and (Math-realp a) (Math-realp b))
X (let ((comp (math-compare a b)))
X (or (eq comp -1)
X (and (eq comp 0)
X (not (equal a b))
X (> (length (memq (car-safe a)
X '(bigneg nil bigpos frac float)))
X (length (memq (car-safe b)
X '(bigneg nil bigpos frac float))))))))
X ((Math-realp a) t)
X ((Math-realp b) nil)
X ((eq (car a) 'var)
X (if (eq (car b) 'var)
X (string-lessp (symbol-name (nth 1 a)) (symbol-name (nth 1 b)))
X (not (Math-numberp b))))
X ((eq (car b) 'var) (Math-numberp a))
X ((eq (car a) (car b))
X (while (and (setq a (cdr a) b (cdr b)) a
X (equal (car a) (car b))))
X (and b
X (or (null a)
X (math-beforep (car a) (car b)))))
X (t (string-lessp (symbol-name (car a)) (symbol-name (car b)))))
X)
X
X
X
X(setq math-living-dangerously nil) ; true if unsafe simplifications are okay.
X
X(defun math-simplify-extended (a)
X (let ((math-living-dangerously t))
X (math-simplify a))
X)
X
X(defun math-simplify (top-expr)
X (calc-with-default-simplification
X (let ((math-simplify-symbolic-powers t)
X res)
X (while (not (equal top-expr (setq res (math-simplify-step
X (math-normalize top-expr)))))
X (setq top-expr res))))
X top-expr
X)
X
X;;; The following has a "bug" in that if any recursive simplifications
X;;; occur only the first handler will be tried; this doesn't really
X;;; matter, since math-simplify-step is iterated to a fixed point anyway.
X(defun math-simplify-step (a)
X (if (Math-primp a)
X a
X (let ((aa (cons (car a) (mapcar 'math-simplify-step (cdr a)))))
X (and (symbolp (car aa))
X (let ((handler (get (car aa) 'math-simplify)))
X (and handler
X (progn
X (while (and handler
X (equal (setq aa (or (funcall (car handler) aa)
X aa))
X a))
X (setq handler (cdr handler)))
X res))))
X aa))
X)
X
X(defmacro math-defsimplify (funcs &rest code)
X "Define a simplification rule for the specified function.
XIf FUNCS is a list of functions, the same rule is applied for each function.
XCODE is a body of Lisp code that returns a simpler form of EXPR.
XMore than one definition may be made per function. All definitions are tried
Xin the order they were encountered; the first non-NIL value which is different
Xfrom the original expression returned is used. The argument EXPR may be
Xdestructively modified."
X (append '(progn)
X (mapcar (function
X (lambda (func)
X (list 'put (list 'quote func) ''math-simplify
X (list 'nconc
X (list 'get (list 'quote func) ''math-simplify)
X (list 'list
X (list 'function
X (append '(lambda (expr))
X code)))))))
X (if (symbolp funcs) (list funcs) funcs)))
X)
X(put 'math-defsimplify 'lisp-indent-hook 1)
X
X(math-defsimplify (+ -)
X (math-simplify-plus))
X
X(defun math-simplify-plus ()
X (cond ((and (memq (car-safe (nth 1 expr)) '(+ -))
X (Math-numberp (nth 2 (nth 1 expr)))
X (not (Math-numberp (nth 2 expr))))
X (let ((x (nth 2 expr))
X (op (car expr)))
X (setcar (cdr (cdr expr)) (nth 2 (nth 1 expr)))
X (setcar expr (car (nth 1 expr)))
X (setcar (cdr (cdr (nth 1 expr))) x)
X (setcar (nth 1 expr) op)))
X ((and (eq (car expr) '+)
X (Math-numberp (nth 1 expr))
X (not (Math-numberp (nth 2 expr))))
X (let ((x (nth 2 expr)))
X (setcar (cdr (cdr expr)) (nth 1 expr))
X (setcar (cdr expr) x))))
X (let ((aa expr)
X aaa temp)
X (while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -))
X (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 expr)
X (eq (car aaa) '-) (eq (car expr) '-) t))
X (progn
X (setcar (cdr (cdr expr)) temp)
X (setcar expr '+)
X (setcar (cdr (cdr aaa)) 0)))
X (setq aa (nth 1 aa)))
X (if (setq temp (math-combine-sum aaa (nth 2 expr)
X nil (eq (car expr) '-) t))
X (progn
X (setcar (cdr (cdr expr)) temp)
X (setcar expr '+)
X (setcar (cdr aa) 0)))
X expr)
X)
X
X(math-defsimplify *
X (math-simplify-times))
X
X(defun math-simplify-times ()
X (if (eq (car-safe (nth 2 expr)) '*)
X (and (math-beforep (nth 1 (nth 2 expr)) (nth 1 expr))
X (let ((x (nth 1 expr)))
X (setcar (cdr expr) (nth 1 (nth 2 expr)))
X (setcar (cdr (nth 2 expr)) x)))
X (and (math-beforep (nth 2 expr) (nth 1 expr))
X (let ((x (nth 2 expr)))
X (setcar (cdr (cdr expr)) (nth 1 expr))
X (setcar (cdr expr) x))))
X (let ((aa expr)
X aaa temp)
X (while (eq (car-safe (setq aaa (nth 2 aa))) '*)
X (if (setq temp (math-combine-prod (nth 1 expr) (nth 1 aaa) nil nil t))
X (progn
X (setcar (cdr expr) temp)
X (setcar (cdr aaa) 1)))
X (setq aa (nth 2 aa)))
X (if (setq temp (math-combine-prod aaa (nth 1 expr) nil nil t))
X (progn
X (setcar (cdr expr) temp)
X (setcar (cdr (cdr aa)) 1)))
X expr)
X)
X
X(math-defsimplify /
X (math-simplify-divide))
X
X(defun math-simplify-divide ()
X (let ((np (cdr expr))
X n nn)
X (setq nn (math-common-constant-factor (nth 2 expr)))
X (if nn
X (progn
X (setq n (math-common-constant-factor (nth 1 expr)))
X (if (and (consp nn) (eq (nth 1 nn) 1) (not n))
X (progn
X (setcar (cdr expr) (math-mul (nth 1 expr) nn))
X (setcar (cdr (cdr expr))
X (math-cancel-common-factor (nth 2 expr) nn)))
X (if (and n (not (eq (setq n (math-frac-gcd n nn)) 1)))
X (progn
X (setcar (cdr expr)
X (math-cancel-common-factor (nth 1 expr) n))
X (setcar (cdr (cdr expr))
X (math-cancel-common-factor (nth 2 expr) n)))))))
X (while (eq (car-safe (setq n (car np))) '*)
X (math-simplify-divisor (cdr n) (cdr (cdr expr)))
X (setq np (cdr (cdr n))))
X (math-simplify-divisor np (cdr (cdr expr)))
X expr)
X)
X
X(defun math-simplify-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-combine-prod n (nth 1 d) nil t t))
X (progn
X (setcar np (setq n temp))
X (setcar (cdr d) 1)))
X (setq dp (cdr (cdr d))))
X (if (setq temp (math-combine-prod n d nil t t))
X (progn
X (setcar np (setq n temp))
X (setcar dp 1))))
X)
X
X(defun math-common-constant-factor (expr)
X (if (Math-primp expr)
X (if (Math-ratp expr)
X (and (not (memq expr '(0 1)))
X (math-abs expr))
X (if (Math-ratp (setq expr (math-to-simple-fraction expr)))
X (math-common-constant-factor expr)))
X (if (memq (car expr) '(+ -))
X (let ((f1 (math-common-constant-factor (nth 1 expr)))
X (f2 (math-common-constant-factor (nth 2 expr))))
X (and f1 f2
X (not (eq (setq f1 (math-frac-gcd f1 f2)) 1))
X f1))
X (if (memq (car expr) '(* /))
X (math-common-constant-factor (nth 1 expr)))))
X)
X
X(defun math-cancel-common-factor (expr val)
X (if (memq (car-safe expr) '(+ -))
X (progn
X (setcar (cdr expr) (math-cancel-common-factor (nth 1 expr) val))
X (setcar (cdr (cdr expr)) (math-cancel-common-factor (nth 2 expr) val))
X expr)
X (math-div expr val))
X)
X
X(defun math-frac-gcd (a b)
X (if (and (Math-integerp a)
X (Math-integerp b))
X (math-gcd a b)
X (or (Math-integerp a) (setq a (list 'frac a 1)))
X (or (Math-integerp b) (setq b (list 'frac b 1)))
X (math-make-frac (math-gcd (nth 1 a) (nth 1 b))
X (math-gcd (nth 2 a) (nth 2 b))))
X)
X
X(math-defsimplify calcFunc-sin
X (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
X (nth 1 (nth 1 expr)))
X (and (math-looks-negp (nth 1 expr))
X (math-neg (list 'calcFunc-sin (math-neg (nth 1 expr)))))
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
X (list 'calcFunc-sqrt (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
X (math-div (nth 1 (nth 1 expr))
X (list 'calcFunc-sqrt
X (math-add 1 (math-sqr (nth 1 (nth 1 expr))))))))
X)
X
X(math-defsimplify calcFunc-cos
X (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
X (nth 1 (nth 1 expr)))
X (and (math-looks-negp (nth 1 expr))
X (list 'calcFunc-cos (math-neg (nth 1 expr))))
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
X (list 'calcFunc-sqrt (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
X (math-div 1
X (list 'calcFunc-sqrt
X (math-add 1 (math-sqr (nth 1 (nth 1 expr))))))))
X)
X
X(math-defsimplify calcFunc-tan
X (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
X (nth 1 (nth 1 expr)))
X (and (math-looks-negp (nth 1 expr))
X (math-neg (list 'calcFunc-tan (math-neg (nth 1 expr)))))
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
X (math-div (nth 1 (nth 1 expr))
X (list 'calcFunc-sqrt
X (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
X (math-div (list 'calcFunc-sqrt
X (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))
X (nth 1 (nth 1 expr)))))
X)
X
X(math-defsimplify calcFunc-sinh
X (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
X (nth 1 (nth 1 expr)))
X)
X
X(math-defsimplify calcFunc-cosh
X (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
X (nth 1 (nth 1 expr)))
X)
X
X(math-defsimplify calcFunc-tanh
X (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
X (nth 1 (nth 1 expr)))
X)
X
X(math-defsimplify calcFunc-arcsin
X (or (and (math-looks-negp (nth 1 expr))
X (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 expr)))))
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-sin)
X (nth 1 (nth 1 expr)))
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
X (math-sub (math-div '(var pi var-pi) 2)
X (nth 1 (nth 1 expr)))))
X)
X
X(math-defsimplify calcFunc-arccos
X (or (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
X (nth 1 (nth 1 expr)))
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-sin)
X (math-sub (math-div '(var pi var-pi) 2)
X (nth 1 (nth 1 expr)))))
X)
X
X(math-defsimplify calcFunc-arctan
X (or (and (math-looks-negp (nth 1 expr))
X (math-neg (list 'calcFunc-arctan (math-neg (nth 1 expr)))))
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-tan)
X (nth 1 (nth 1 expr))))
X)
X
X(math-defsimplify calcFunc-arcsinh
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-sinh)
X (nth 1 (nth 1 expr)))
X)
X
X(math-defsimplify calcFunc-arccosh
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-cosh)
X (nth 1 (nth 1 expr)))
X)
X
X(math-defsimplify calcFunc-arctanh
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-tanh)
X (nth 1 (nth 1 expr)))
X)
X
X(math-defsimplify calcFunc-sqrt
X (or (let ((fac (math-common-constant-factor (nth 1 expr))))
X (and fac
X (math-mul (list 'calcFunc-sqrt fac)
X (list 'calcFunc-sqrt
X (math-cancel-common-factor (nth 1 expr) fac)))))
X (and (eq (car-safe (nth 1 expr)) '-)
X (math-equal-int (nth 1 (nth 1 expr)) 1)
X (eq (car-safe (nth 2 (nth 1 expr))) '^)
X (math-equal-int (nth 2 (nth 2 (nth 1 expr))) 2)
X (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr)))) 'calcFunc-sin)
X (list 'calcFunc-cos
X (nth 1 (nth 1 (nth 2 (nth 1 expr))))))
X (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr)))) 'calcFunc-cos)
X (list 'calcFunc-sin
X (nth 1 (nth 1 (nth 2 (nth 1 expr))))))))
X (and math-living-dangerously
X (or (and (eq (car-safe (nth 1 expr)) '^)
X (list '^
X (nth 1 (nth 1 expr))
X (math-div (nth 2 (nth 1 expr)) 2)))
X (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt)
X (list '^ (nth 1 (nth 1 expr)) (math-div 1 4))))))
X)
X
X(math-defsimplify 'calcFunc-exp
X (and (eq (car-safe (nth 1 expr)) 'calcFunc-ln)
X (nth 1 (nth 1 expr)))
X)
X
X(math-defsimplify 'calcFunc-ln
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) 'calcFunc-exp)
X (nth 1 (nth 1 expr)))
X)
X
X(math-defsimplify '^
X (math-simplify-pow))
X
X(defun math-simplify-pow ()
X (or (and math-living-dangerously
X (or (and (eq (car-safe (nth 1 expr)) '^)
X (list '^
X (nth 1 (nth 1 expr))
X (math-mul (nth 2 expr) (nth 2 (nth 1 expr)))))
X (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt)
X (list '^
X (nth 1 (nth 1 expr))
X (math-div (nth 2 expr) 2)))))
X (and (math-equal-int (nth 1 expr) 10)
X (eq (car-safe (nth 2 expr)) 'calcFunc-log10)
X (nth 1 (nth 2 expr)))
X (and (equal (nth 1 expr) '(var e var-e))
X (eq (car-safe (nth 2 expr)) 'calcFunc-ln)
X (nth 1 (nth 2 expr))))
X)
X
X(math-defsimplify 'calcFunc-log10
X (and math-living-dangerously
X (eq (car-safe (nth 1 expr)) '^)
X (math-equal-int (nth 1 (nth 1 expr)) 10)
X (nth 2 (nth 1 expr)))
X)
X
X
X
X
X(defun math-expand-term (expr)
X (cond ((and (eq (car-safe expr) '*)
X (memq (car-safe (nth 1 expr)) '(+ -)))
X (math-add-or-sub (math-mul (nth 1 (nth 1 expr)) (nth 2 expr))
X (math-mul (nth 2 (nth 1 expr)) (nth 2 expr))
X nil (eq (car (nth 1 expr)) '-)))
X ((and (eq (car-safe expr) '*)
X (memq (car-safe (nth 2 expr)) '(+ -)))
X (math-add-or-sub (math-mul (nth 1 expr) (nth 1 (nth 2 expr)))
X (math-mul (nth 1 expr) (nth 2 (nth 2 expr)))
X nil (eq (car (nth 2 expr)) '-)))
X ((and (eq (car-safe expr) '/)
X (memq (car-safe (nth 1 expr)) '(+ -)))
X (math-add-or-sub (math-div (nth 1 (nth 1 expr)) (nth 2 expr))
X (math-div (nth 2 (nth 1 expr)) (nth 2 expr))
X nil (eq (car (nth 1 expr)) '-)))
X ((and (eq (car-safe expr) '^)
X (memq (car-safe (nth 1 expr)) '(+ -))
X (integerp (nth 2 expr))
X (if (> (nth 2 expr) 0)
X (list '*
X (nth 1 expr)
X (math-pow (nth 1 expr) (1- (nth 2 expr))))
X (if (< (nth 2 expr) 0)
X (math-div 1 (math-pow (nth 1 expr)
X (- (nth 2 expr))))))))
X (t expr))
X)
X
X(defun math-expand-tree (expr &optional many)
X (math-map-tree 'math-expand-term expr many)
X)
X
X(defun math-map-tree (mmt-func mmt-expr &optional mmt-many)
X (or mmt-many (setq mmt-many 1000000))
X (math-map-tree-rec mmt-expr)
X)
X
X(defun math-map-tree-rec (mmt-expr)
X (or (= mmt-many 0)
X (let ((mmt-done nil)
X mmt-nextval)
X (while (not mmt-done)
X (while (and (/= mmt-many 0)
X (setq mmt-nextval (funcall mmt-func mmt-expr))
X (not (equal mmt-expr mmt-nextval)))
X (setq mmt-expr mmt-nextval
X mmt-many (if (> mmt-many 0) (1- mmt-many) (1+ mmt-many))))
X (if (or (Math-primp mmt-expr)
X (<= mmt-many 0))
X (setq mmt-done t)
X (setq mmt-nextval (cons (car mmt-expr)
X (mapcar 'math-map-tree-rec (cdr mmt-expr))))
X (if (equal mmt-nextval mmt-expr)
X (setq mmt-done t)
X (setq mmt-expr mmt-nextval))))))
X mmt-expr
X)
X
X
X
X
X(defun math-apply-rewrite (expr lhs rhs &optional cond)
X (let ((matches-found nil))
X (and (math-match-pattern expr lhs)
X (or (null cond)
X (math-is-true (math-simplify (math-replace-variables cond))))
X (math-replace-variables rhs)))
X)
X
X(defun math-apply-rewrite-rules (expr rules)
X (let ((r rules)
X next)
X (while (and r
X (or (not (setq next (math-apply-rewrite expr
X (nth 1 (car r))
X (nth 2 (car r))
X (nth 3 (car r)))))
X (equal expr (setq next (math-normalize next)))))
X (setq r (cdr r)))
X (and r
X next))
X)
X
X(defun math-rewrite (expr rules &optional many)
X (setq rules (math-check-rewrite-rules rules))
X (math-map-tree (function (lambda (x) (math-apply-rewrite-rules x rules)))
X expr many)
X)
X
X(defun math-check-rewrite-rules (rules)
X (if (and (eq (car-safe rules) 'var)
X (boundp (nth 2 rules))
X (symbol-value (nth 2 rules)))
X (setq rules (symbol-value (nth 2 rules))))
X (or (Math-vectorp rules)
X (error "Rules must be a vector"))
X (setq rules (if (Math-vectorp (nth 1 rules))
X (cdr rules)
X (list rules)))
X (let ((r rules))
X (while r
X (or (and (Math-vectorp (car r))
X (cdr (cdr (car r)))
X (not (nthcdr 4 (car r))))
X (error "Malformed rules vector"))
X (setq r (cdr r))))
X rules
X)
X
X(defun math-match-pattern (expr pat)
X (cond ((Math-primp pat)
X (or (math-equal expr pat)
X (and (eq (car-safe pat) 'var)
X (let ((match (assq (nth 1 pat) matches-found)))
X (if match
X (equal expr (nth 1 match))
X (setq matches-found (cons (list (nth 1 pat)
X expr)
X matches-found)))))))
X ((eq (car pat) 'calcFunc-quote)
X (equal expr (nth 1 pat)))
X (t
X (and (eq (car pat) (car-safe expr))
X (progn
X (while (and (setq expr (cdr expr) pat (cdr pat))
X expr
X (math-match-pattern (car expr) (car pat))))
X (and (null expr) (null pat))))))
X)
X
X(defun math-replace-variables (expr)
X (if (Math-primp expr)
X (if (eq (car-safe expr) 'var)
X (let ((match (assq (nth 1 expr) matches-found)))
X (if match
X (nth 1 match)
X expr))
X expr)
X (cons (car expr) (mapcar 'math-replace-variables (cdr expr))))
X)
X
X(defun math-is-true (expr)
X (and (Math-realp expr)
X (not (Math-zerop expr)))
X)
X
X
X
X
X(defun math-derivative (expr) ; uses global values: deriv-var, deriv-total.
X (cond ((equal expr deriv-var)
X 1)
X ((or (Math-scalarp expr)
X (eq (car expr) 'sdev)
X (and (eq (car expr) 'var)
X (not deriv-total)))
X 0)
X ((eq (car expr) '+)
X (math-add (math-derivative (nth 1 expr))
X (math-derivative (nth 2 expr))))
X ((eq (car expr) '-)
X (math-sub (math-derivative (nth 1 expr))
X (math-derivative (nth 2 expr))))
X ((eq (car expr) 'neg)
X (math-neg (math-derivative (nth 1 expr))))
X ((eq (car expr) '*)
X (math-add (math-mul (nth 2 expr)
X (math-derivative (nth 1 expr)))
X (math-mul (nth 1 expr)
X (math-derivative (nth 2 expr)))))
X ((eq (car expr) '/)
X (math-sub (math-div (math-derivative (nth 1 expr))
X (nth 2 expr))
X (math-div (math-mul (nth 1 expr)
X (math-derivative (nth 2 expr)))
X (math-sqr (nth 2 expr)))))
X ((eq (car expr) '^)
X (let ((du (math-derivative (nth 1 expr)))
X (dv (math-derivative (nth 2 expr))))
X (or (Math-zerop du)
X (setq du (math-mul (nth 2 expr)
X (math-mul (math-normalize
X (list '^
X (nth 1 expr)
X (math-add (nth 2 expr) -1)))
X du))))
X (or (Math-zerop dv)
X (setq dv (math-mul (math-normalize
X (list 'calcFunc-ln (nth 1 expr)))
X (math-mul expr dv))))
X (math-add du dv)))
X ((eq (car expr) '%)
X (math-derivative (nth 1 expr))) ; a reasonable definition
X ((eq (car expr) 'vec)
X (math-map-vec 'math-derivative expr))
X ((and (eq (car expr) 'calcFunc-log)
X (= (length expr) 3)
X (not (Math-zerop (nth 2 expr))))
X (let ((lnv (math-normalize (list 'calcFunc-ln (nth 2 expr)))))
X (math-sub (math-div (math-derivative (nth 1 expr))
X (math-mul lnv (nth 1 expr)))
X (math-div (math-derivative (nth 2 expr))
X (math-mul (math-sqr lnv)
X (nth 2 expr))))))
X (t (or (and (= (length expr) 2)
X (symbolp (car expr))
X (let ((handler (get (car expr) 'math-derivative)))
X (and handler
X (let ((deriv (math-derivative (nth 1 expr))))
X (if (Math-zerop deriv)
X deriv
X (math-mul (funcall handler (nth 1 expr))
X deriv))))))
X (if deriv-symb
X (throw 'math-deriv nil)
X (if (or (Math-objvecp expr)
X (not (symbolp (car expr))))
X (list (if deriv-total 'calcFunc-tderiv 'calcFunc-deriv)
X expr
X deriv-var)
X (let ((accum 0)
X (arg expr)
X (n 1)
X derv)
X (while (setq arg (cdr arg))
X (or (Math-zerop (setq derv (math-derivative (car arg))))
X (let ((func (intern (concat (symbol-name (car expr))
X "'"
X (if (> n 1)
X (int-to-string n)
X "")))))
X (setq accum (math-add
X accum
X (math-mul derv
X (cons func
X (cdr expr)))))))
X (setq n (1+ n)))
X accum))))))
X)
X
X(defun calcFunc-deriv (expr deriv-var &optional deriv-value deriv-symb)
X (let* ((deriv-total nil)
X (res (catch 'math-deriv (math-derivative expr))))
X (or (eq (car-safe res) 'calcFunc-deriv)
X (null res)
X (setq res (math-normalize res)))
X (and res
X (if deriv-value
X (math-expr-subst res deriv-var deriv-value)
X res)))
X)
X
X(defun calcFunc-tderiv (expr deriv-var &optional deriv-value deriv-symb)
X (let* ((deriv-total t)
X (res (catch 'math-deriv (math-derivative expr))))
X (or (eq (car-safe res) 'calcFunc-tderiv)
X (null res)
X (setq res (math-normalize res)))
X (and res
X (if deriv-value
X (math-expr-subst res deriv-var deriv-value)
X res)))
X)
X
X(put 'calcFunc-inv 'math-derivative
X (function (lambda (u) (math-neg (math-div 1 (math-sqr u))))))
X
X(put 'calcFunc-sqrt 'math-derivative
X (function (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u))))))
X
X(put 'calcFunc-conj 'math-derivative
X (function (lambda (u) (math-normalize (list 'calcFunc-conj u)))))
X
X(put 'calcFunc-deg 'math-derivative
X (function (lambda (u) (math-div (math-pi-over-180) u))))
X
X(put 'calcFunc-rad 'math-derivative
X (function (lambda (u) (math-mul (math-pi-over-180) u))))
X
X(put 'calcFunc-ln 'math-derivative
X (function (lambda (u) (math-div 1 u))))
X
X(put 'calcFunc-log10 'math-derivative
X (function (lambda (u)
X (math-div (math-div 1 (math-normalize '(calcFunc-ln 10)))
X u))))
X
X(put 'calcFunc-lnp1 'math-derivative
X (function (lambda (u) (math-div 1 (math-add u 1)))))
X
X(put 'calcFunc-exp 'math-derivative
X (function (lambda (u) (math-normalize (list 'calcFunc-exp u)))))
X
X(put 'calcFunc-expm1 'math-derivative
X (function (lambda (u) (math-normalize (list 'calcFunc-expm1 u)))))
X
X(put 'calcFunc-sin 'math-derivative
X (function (lambda (u) (math-to-radians-2 (math-normalize
X (list 'calcFunc-cos u))))))
X
X(put 'calcFunc-cos 'math-derivative
X (function (lambda (u) (math-neg (math-to-radians-2
X (math-normalize
X (list 'calcFunc-sin u)))))))
X
X(put 'calcFunc-tan 'math-derivative
X (function (lambda (u) (math-to-radians-2
X (math-div 1 (math-sqr
X (math-normalize
X (list 'calcFunc-cos u))))))))
X
X(put 'calcFunc-arcsin 'math-derivative
X (function (lambda (u)
X (math-from-radians-2
X (math-div 1 (math-normalize
X (list 'calcFunc-sqrt
X (math-sub 1 (math-sqr u)))))))))
X
X(put 'calcFunc-arccos 'math-derivative
X (function (lambda (u)
X (math-from-radians-2
X (math-div -1 (math-normalize
X (list 'calcFunc-sqrt
X (math-sub 1 (math-sqr u)))))))))
X
X(put 'calcFunc-arctan 'math-derivative
X (function (lambda (u) (math-from-radians-2
X (math-div 1 (math-add 1 (math-sqr u)))))))
X
X(put 'calcFunc-sinh 'math-derivative
X (function (lambda (u) (math-normalize (list 'calcFunc-cosh u)))))
X
X(put 'calcFunc-cosh 'math-derivative
X (function (lambda (u) (math-normalize (list 'calcFunc-sinh u)))))
X
X(put 'calcFunc-tanh 'math-derivative
X (function (lambda (u) (math-div 1 (math-sqr
X (math-normalize
X (list 'calcFunc-cosh u)))))))
X
X(put 'calcFunc-arcsinh 'math-derivative
X (function (lambda (u)
X (math-div 1 (math-normalize
X (list 'calcFunc-sqrt
X (math-add (math-sqr u) 1)))))))
X
X(put 'calcFunc-arccosh 'math-derivative
X (function (lambda (u)
X (math-div 1 (math-normalize
X (list 'calcFunc-sqrt
X (math-add (math-sqr u) -1)))))))
X
X(put 'calcFunc-arctanh 'math-derivative
X (function (lambda (u) (math-div 1 (math-sub 1 (math-sqr u))))))
X
X
X
X(setq math-integ-var '(var X ---))
X(setq math-integ-var-2 '(var Y ---))
X(setq math-integ-vars (list 'f math-integ-var math-integ-var-2))
X
X(defmacro math-tracing-integral (&rest parts)
X (list 'and
X 'trace-buffer
X (list 'save-excursion
X '(set-buffer trace-buffer)
X '(goto-char (point-max))
X (list 'and
X '(bolp)
X '(insert (make-string (- calc-integral-limit
X math-integ-level) 32)
X (format "%2d " math-integ-depth)
X (make-string math-integ-level 32)))
X (cons 'insert parts)
X '(sit-for 0)))
X)
X
X;;; The following wrapper caches results and avoids infinite recursion.
X;;; Each cache entry is: ( A B ) Integral of A is B;
X;;; ( A N ) Integral of A failed at level N;
X;;; ( A busy ) Currently working on integral of A;
X;;; ( A parts ) Currently working, integ-by-parts;
X;;; ( A parts2 ) Currently working, integ-by-parts;
X;;; ( A cancelled ) Ignore this cache entry;
X;;; ( A [B] ) Same result as for cur-record = B.
X(defun math-integral (expr &optional simplify same-as-above)
X (let* ((simp cur-record)
X (cur-record (assoc expr math-integral-cache))
X (math-integ-depth (1+ math-integ-depth))
X (val 'cancelled))
X (math-tracing-integral "Integrating "
X (math-format-value expr 1000)
X "...\n")
X (and cur-record
X (progn
X (math-tracing-integral "Found "
X (math-format-value (nth 1 cur-record) 1000))
X (and (consp (nth 1 cur-record))
X (math-replace-integral-parts cur-record))
X (math-tracing-integral " => "
X (math-format-value (nth 1 cur-record) 1000)
X "\n")))
X (or (and cur-record
X (not (eq (nth 1 cur-record) 'cancelled))
X (or (not (integerp (nth 1 cur-record)))
X (>= (nth 1 cur-record) math-integ-level)))
X (and (consp expr)
X (eq (car expr) 'var)
X (eq (nth 1 expr) 'PARTS)
X (listp (nth 2 expr))
X (progn
X (setq val nil)
X t))
X (unwind-protect
X (progn
X (let (math-integ-msg)
X (if (eq calc-display-working-message 'lots)
X (progn
X (calc-set-command-flag 'clear-message)
X (setq math-integ-msg (format
X "Working... Integrating %s"
X (math-format-flat-expr expr 0)))
X (message math-integ-msg)))
X (if cur-record
X (setcar (cdr cur-record)
X (if same-as-above (vector simp) 'busy))
X (setq cur-record
X (list expr (if same-as-above (vector simp) 'busy))
X math-integral-cache (cons cur-record
X math-integral-cache)))
X (if (eq simplify 'yes)
X (progn
X (math-tracing-integral "Simplifying...")
X (setq simp (math-simplify expr))
X (setq val (if (equal simp expr)
X (progn
X (math-tracing-integral " no change\n")
X (math-do-integral expr))
X (math-tracing-integral " simplified\n")
X (math-integral simp 'no t))))
X (or (setq val (math-do-integral expr))
X (eq simplify 'no)
X (let ((simp (math-simplify expr)))
X (or (equal simp expr)
X (progn
X (math-tracing-integral "Trying again after "
X "simplification...\n")
X (setq val (math-integral simp 'no t))))))))
X (if (eq calc-display-working-message 'lots)
X (message math-integ-msg)))
X (setcar (cdr cur-record) (or val math-integ-level))))
X (setq val cur-record)
X (while (vectorp (nth 1 val))
X (setq val (aref (nth 1 val) 0)))
X (setq val (if (memq (nth 1 val) '(parts parts2))
X (progn
X (setcar (cdr val) 'parts2)
X (list 'var 'PARTS val))
X (and (not (eq (nth 1 val) 'busy))
X (not (integerp (nth 1 val)))
X (nth 1 val))))
X (math-tracing-integral "Integral of "
X (math-format-value expr 1000)
X " is "
X (math-format-value val 1000)
X "\n")
X val)
X)
X(defvar math-integral-cache nil)
X(defvar math-integral-cache-state nil)
X
X(defun math-replace-integral-parts (expr)
X (or (Math-primp expr)
X (while (setq expr (cdr expr))
X (and (consp (car expr))
X (if (eq (car (car expr)) 'var)
X (and (eq (nth 1 (car expr)) 'PARTS)
X (consp (nth 2 (car expr)))
X (if (listp (nth 1 (nth 2 (car expr))))
X (progn
X (setcar expr (nth 1 (nth 2 (car expr))))
X (math-replace-integral-parts (cons 'foo expr)))
X (setcar (cdr cur-record) 'cancelled)))
X (math-replace-integral-parts (car expr))))))
X)
X
X(defun math-do-integral (expr)
X (let (t1 t2)
X (or (cond ((not (math-expr-contains expr math-integ-var))
X (math-mul expr math-integ-var))
X ((equal expr math-integ-var)
X (math-div (math-sqr expr) 2))
X ((eq (car expr) '+)
X (and (setq t1 (math-integral (nth 1 expr)))
X (setq t2 (math-integral (nth 2 expr)))
X (math-add t1 t2)))
X ((eq (car expr) '-)
X (and (setq t1 (math-integral (nth 1 expr)))
X (setq t2 (math-integral (nth 2 expr)))
X (math-sub t1 t2)))
X ((eq (car expr) 'neg)
X (and (setq t1 (math-integral (nth 1 expr)))
X (math-neg t1)))
X ((eq (car expr) '*)
X (cond ((not (math-expr-contains (nth 1 expr) math-integ-var))
X (and (setq t1 (math-integral (nth 2 expr)))
X (math-mul (nth 1 expr) t1)))
X ((not (math-expr-contains (nth 2 expr) math-integ-var))
X (and (setq t1 (math-integral (nth 1 expr)))
X (math-mul t1 (nth 2 expr))))
X ((memq (car-safe (nth 1 expr)) '(+ -))
X (math-integral (list (car (nth 1 expr))
X (math-mul (nth 1 (nth 1 expr))
X (nth 2 expr))
X (math-mul (nth 2 (nth 1 expr))
X (nth 2 expr)))
X 'yes t))
X ((memq (car-safe (nth 2 expr)) '(+ -))
X (math-integral (list (car (nth 2 expr))
X (math-mul (nth 1 (nth 2 expr))
X (nth 1 expr))
X (math-mul (nth 2 (nth 2 expr))
X (nth 1 expr)))
X 'yes t))))
X ((eq (car expr) '/)
X (cond ((not (math-expr-contains (nth 2 expr) math-integ-var))
X (and (setq t1 (math-integral (nth 1 expr)))
X (math-div t1 (nth 2 expr))))
X ((and (eq (car-safe (nth 1 expr)) '*)
X (not (math-expr-contains (nth 1 (nth 1 expr))
X math-integ-var)))
X (and (setq t1 (math-integral
X (math-div (nth 2 (nth 1 expr))
X (nth 2 expr))))
X (math-mul t1 (nth 1 (nth 1 expr)))))
X ((and (eq (car-safe (nth 2 expr)) '*)
X (not (math-expr-contains (nth 1 (nth 2 expr))
X math-integ-var)))
X (and (setq t1 (math-integral
X (math-div (nth 1 expr)
X (nth 2 (nth 2 expr)))))
X (math-div t1 (nth 1 (nth 2 expr)))))
X ((memq (car-safe (nth 1 expr)) '(+ -))
X (math-integral (list (car (nth 1 expr))
X (math-div (nth 1 (nth 1 expr))
X (nth 2 expr))
X (math-div (nth 2 (nth 1 expr))
X (nth 2 expr)))
X 'yes t))))
X ((eq (car expr) '^)
X (cond ((not (math-expr-contains (nth 1 expr) math-integ-var))
X (or (and (setq t1 (math-is-polynomial (nth 2 expr)
X math-integ-var 1))
X (math-div expr
X (math-mul (nth 1 t1)
X (math-normalize
X (list 'calcFunc-ln
X (nth 1 expr))))))
X (math-integral
X (list 'calcFunc-exp
X (math-mul (nth 2 expr)
X (math-normalize
X (list 'calcFunc-ln
X (nth 1 expr)))))
X 'yes t)))
X ((not (math-expr-contains (nth 2 expr) math-integ-var))
X (if (Math-equal-int (nth 2 expr) -1)
X (math-integral (math-div 1 (nth 1 expr)) nil t)
X (or (and (setq t1 (math-is-polynomial (nth 1 expr)
X math-integ-var
X 1))
X (setq t2 (math-add (nth 2 expr) 1))
X (math-div (math-pow (nth 1 expr) t2)
X (math-mul t2 (nth 1 t1))))
X (and (Math-negp (nth 2 expr))
X (math-integral
X (math-div 1
X (math-pow (nth 1 expr)
X (math-neg
X (nth 2 expr))))
X nil t))
X nil))))))
X
X ;; Integral of a polynomial.
X (and (setq t1 (math-is-polynomial expr math-integ-var 20))
X (let ((accum 0)
X (n 1))
X (while t1
X (if (setq accum (math-add accum
X (math-div (math-mul (car t1)
X (math-pow
X math-integ-var
X n))
X n))
X t1 (cdr t1))
X (setq n (1+ n))))
X accum))
X
X ;; Try looking it up!
X (cond ((= (length expr) 2)
X (and (symbolp (car expr))
X (setq t1 (get (car expr) 'math-integral))
X (progn
X (while (and t1
X (not (setq t2 (funcall (car t1)
X (nth 1 expr)))))
X (setq t1 (cdr t1)))
X (and t2 (math-normalize t2)))))
X ((= (length expr) 3)
X (and (symbolp (car expr))
X (setq t1 (get (car expr) 'math-integral-2))
X (progn
X (while (and t1
X (not (setq t2 (funcall (car t1)
X (nth 1 expr)
X (nth 2 expr)))))
X (setq t1 (cdr t1)))
X (and t2 (math-normalize t2))))))
X
X ;; Integration by substitution, for various likely sub-expressions.
X ;; (We should also try some of the classic non-obvious substitutions.)
X (let ((so-far nil))
X (math-integ-try-substitutions expr))
X
X ;; Integration by parts:
X ;; integ(f(x) g(x),x) = f(x) h(x) - integ(h(x) f'(x),x)
X ;; where h(x) = integ(g(x),x).
X (and (eq (car expr) '*)
X (not (math-polynomial-p (nth 2 expr) math-integ-var))
X (math-integrate-by-parts (nth 1 expr) (nth 2 expr)))
X (and (eq (car expr) '/)
X (math-expr-contains (nth 1 expr) math-integ-var)
X (let ((recip (math-div 1 (nth 2 expr))))
X (or (math-integrate-by-parts (nth 1 expr) recip)
X (math-integrate-by-parts recip (nth 1 expr)))))
X (and (eq (car expr) '^)
X (math-integrate-by-parts (nth 1 expr)
X (math-pow (nth 1 expr)
X (math-sub (nth 2 expr) 1))))
X
X ;; Symmetries.
X (and (eq (car expr) '*)
X (math-integral (list '* (nth 2 expr) (nth 1 expr)) 'no t))
X
X ;; Give up.
X nil))
X)
X
X(defun math-integrate-by-parts (u vprime)
X (and (> math-integ-level 0)
X (not (boundp 'math-disable-parts))
X (let ((math-integ-level (1- math-integ-level))
X v temp)
X (unwind-protect
X (progn
X (setcar (cdr cur-record) 'parts)
X (math-tracing-integral "Integrating by parts, u = "
X (math-format-value u 1000)
X ", v' = "
X (math-format-value vprime 1000)
X "\n")
X (and (setq v (math-integral vprime))
X (setq temp (calcFunc-deriv u
X math-integ-var
X nil t))
X (setq temp (math-integral (math-mul v temp) 'yes))
X (setq temp (math-sub (math-mul u v) temp))
X (if (eq (nth 1 cur-record) 'parts)
X temp
X (setq v (list 'var 'PARTS cur-record)
X temp (math-solve-for (math-sub v temp) 0 v nil))
X (and temp (math-simplify-extended temp)))))
X (setcar (cdr cur-record) 'busy))))
X)
X
X;;; This tries two different formulations, hoping the algebraic simplifier
X;;; will be strong enough to handle at least one.
X(defun math-integrate-by-substitution (expr u)
X (and (> math-integ-level 0)
X (let ((math-integ-level (1- math-integ-level))
X (math-living-dangerously t)
X uinv deriv temp)
X (and (setq uinv (math-solve-for u
X math-integ-var-2
X math-integ-var nil))
X (progn
X (math-tracing-integral "Integrating by substitution, u = "
X (math-format-value u 1000)
X "\n")
X (or (and (not (boundp 'math-disable-subst1))
X (setq deriv (calcFunc-deriv u
X math-integ-var nil t))
X (setq temp (math-integral (math-expr-subst
X (math-expr-subst
X (math-expr-subst
X (math-div expr deriv)
X u
X math-integ-var-2)
X math-integ-var
X uinv)
X math-integ-var-2
X math-integ-var)
X 'yes)))
X (and (not (boundp 'math-disable-subst2))
X (setq deriv (calcFunc-deriv uinv
X math-integ-var-2
X math-integ-var t))
X (setq temp (math-integral (math-mul
X (math-expr-subst
X (math-expr-subst
X (math-expr-subst
X expr
X u
X math-integ-var-2)
X math-integ-var
X uinv)
X math-integ-var-2
X math-integ-var)
X deriv)
X 'yes)))))
X (math-simplify-extended
X (math-expr-subst temp math-integ-var u)))))
X)
X
X;;; Recursively try different substitutions based on various sub-expressions.
X(defun math-integ-try-substitutions (sub-expr)
X (and (not (Math-primp sub-expr))
X (math-expr-contains sub-expr math-integ-var)
X (not (equal sub-expr math-integ-var))
X (not (assoc sub-expr so-far))
X (or (and (not (eq sub-expr expr))
X (math-integrate-by-substitution expr sub-expr))
X (let ((res nil))
X (setq so-far (cons (list sub-expr) so-far))
X (while (and (setq sub-expr (cdr sub-expr))
X (not (setq res (math-integ-try-substitutions
X (car sub-expr))))))
X res)))
X)
X
X(defun math-fix-const-terms (expr except-vars)
X (cond ((not (math-expr-depends expr except-vars)) 0)
X ((Math-primp expr) expr)
X ((eq (car expr) '+)
X (math-add (math-fix-const-terms (nth 1 expr) except-vars)
X (math-fix-const-terms (nth 2 expr) except-vars)))
X ((eq (car expr) '-)
X (math-sub (math-fix-const-terms (nth 1 expr) except-vars)
X (math-fix-const-terms (nth 2 expr) except-vars)))
X (t expr))
X)
X
X(defun calc-dump-integral-cache (&optional arg)
X "Command for debugging the Calculator's symbolic integrator."
X (interactive "P")
X (let ((buf (current-buffer)))
X (unwind-protect
X (let ((p math-integral-cache)
X cur-record)
X (display-buffer (get-buffer-create "*Integral Cache*"))
X (set-buffer (get-buffer "*Integral Cache*"))
X (erase-buffer)
X (while p
X (setq cur-record (car p))
X (or arg (math-replace-integral-parts cur-record))
X (insert (math-format-flat-expr (car cur-record) 0)
X " --> "
X (if (symbolp (nth 1 cur-record))
X (concat "(" (symbol-name (nth 1 cur-record)) ")")
X (math-format-flat-expr (nth 1 cur-record) 0))
X "\n")
X (setq p (cdr p)))
X (goto-char (point-min)))
X (set-buffer buf)))
X)
X
X(defun calcFunc-integ (expr var &optional low high)
X (let ((state (list calc-angle-mode
X calc-symbolic-mode
X calc-prefer-frac
X calc-internal-prec)))
X (or (equal state math-integral-cache-state)
X (setq math-integral-cache-state state
X math-integral-cache nil)))
X (let* ((math-integ-level calc-integral-limit)
X (math-integ-depth 0)
X (math-integ-msg "Working...done")
X (cur-record nil) ; a technicality
X (sexpr (math-expr-subst expr var math-integ-var))
X (trace-buffer (get-buffer "*Trace*"))
X (calc-language (if (eq calc-language 'big) nil calc-language))
X (res (if trace-buffer
X (let ((calcbuf (current-buffer))
X (calcwin (selected-window)))
X (unwind-protect
X (progn
X (if (get-buffer-window trace-buffer)
X (select-window (get-buffer-window trace-buffer)))
X (set-buffer trace-buffer)
X (goto-char (point-max))
X (or (assq 'scroll-stop (buffer-local-variables))
X (progn
X (make-local-variable 'scroll-step)
X (setq scroll-step 3)))
X (insert "\n\n\n")
X (set-buffer calcbuf)
X (math-integral sexpr 'yes))
X (select-window calcwin)
X (set-buffer calcbuf)))
X (math-integral sexpr 'yes))))
X (if res
X (math-normalize
X (if (and low high)
X (math-sub (math-expr-subst res math-integ-var high)
X (math-expr-subst res math-integ-var low))
X (setq res (math-fix-const-terms res math-integ-vars))
X (if low
X (math-expr-subst res math-integ-var low)
X (math-expr-subst res math-integ-var var))))
X (append (list 'calcFunc-integ expr var)
X (and low (list low))
X (and high (list high)))))
X)
X
X(defmacro math-defintegral (funcs &rest code)
X "Define an integration rule for the specified function.
XIf FUNCS is a list of functions, the same rule is applied for each function.
XCODE is a body of Lisp code that returns the integral of FUNCS(U).
XMore than one definition may be made per function. All definitions are tried
Xin the order they were encountered; the first non-NIL value returned is used."
X (setq math-integral-cache nil)
X (append '(progn)
X (mapcar (function
X (lambda (func)
X (list 'put (list 'quote func) ''math-integral
X (list 'nconc
X (list 'get (list 'quote func) ''math-integral)
X (list 'list
X (list 'function
X (append '(lambda (u))
X code)))))))
X (if (symbolp funcs) (list funcs) funcs)))
X)
X(put 'math-defintegral 'lisp-indent-hook 1)
X
X(defmacro math-defintegral-2 (funcs &rest code)
X "Define an integration rule for the specified function.
XIf FUNCS is a list of functions, the same rule is applied for each function.
XCODE is a body of Lisp code that returns the integral of FUNCS(U,V).
XMore than one definition may be made per function. All definitions are tried
Xin the order they were encountered; the first non-NIL value returned is used."
X (setq math-integral-cache nil)
X (append '(progn)
X (mapcar (function
X (lambda (func)
X (list 'put (list 'quote func) ''math-integral-2
X (list 'nconc
X (list 'get (list 'quote func)
SHAR_EOF
echo "End of part 9"
echo "File calc-ext.el is continued in part 10"
echo "10" > s2_seq_.tmp
exit 0