Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume24/gnucalc/part08

Text File | 1991-10-29 | 55.3 KB | 1,899 lines

Newsgroups: comp.sources.misc
From: [e-mail] (David Gillespie)
Subject:  v24i056:  gnucalc - GNU Emacs Calculator, v2.00, Part08/56
Message-ID: <[e-mail]>
X-Md4-Signature: da4707b63937149a0325ffa6456ffa96
Date: Tue, 29 Oct 1991 22:59:27 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (David Gillespie)
Posting-number: Volume 24, Issue 56
Archive-name: gnucalc/part08
Environment: Emacs
Supersedes: gmcalc: Volume 13, Issue 27-45

---- Cut Here and unpack ----
#!/bin/sh
# this is Part.08 (part 8 of a multipart archive)
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc-alg.el continued
#
if test ! -r _shar_seq_.tmp; then
    echo 'Please unpack part 1 first!'
    exit 1
fi
(read Scheck
 if test "$Scheck" != 8; then
    echo Please unpack part "$Scheck" next!
    exit 1
 else
    exit 0
 fi
) < _shar_seq_.tmp || exit 1
if test ! -f _shar_wnt_.tmp; then
    echo 'x - still skipping calc-alg.el'
else
echo 'x - continuing file calc-alg.el'
sed 's/^X//' << 'SHAR_EOF' >> 'calc-alg.el' &&
X           ((eq x 1) (nth 1 expr))
X           ((eq x 2) -1)
X           ((eq x 3) (math-neg (nth 1 expr))))))
X      (and math-integrating
X       (integerp (nth 2 expr))
X       (>= (nth 2 expr) 2)
X       (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
X            (math-mul (math-pow (nth 1 expr) (- (nth 2 expr) 2))
X                  (math-sub 1
X                    (math-sqr
X                     (list 'calcFunc-sin
X                           (nth 1 (nth 1 expr)))))))
X           (and (eq (car-safe (nth 1 expr)) 'calcFunc-cosh)
X            (math-mul (math-pow (nth 1 expr) (- (nth 2 expr) 2))
X                  (math-add 1
X                    (math-sqr
X                     (list 'calcFunc-sinh
X                           (nth 1 (nth 1 expr)))))))))
X      (and (eq (car-safe (nth 2 expr)) 'frac)
X       (Math-ratp (nth 1 expr))
X       (Math-posp (nth 1 expr))
X       (if (equal (nth 2 expr) '(frac 1 2))
X           (list 'calcFunc-sqrt (nth 1 expr))
X         (let ((flr (math-floor (nth 2 expr))))
X           (and (not (Math-zerop flr))
X            (list '* (list '^ (nth 1 expr) flr)
X              (list '^ (nth 1 expr)
X                (math-sub (nth 2 expr) flr)))))))
X      (and (eq (math-quarter-integer (nth 2 expr)) 2)
X       (let ((temp (math-simplify-sqrt)))
X         (and temp
X          (list '^ temp (math-mul (nth 2 expr) 2))))))
)
X
(math-defsimplify calcFunc-log10
X  (and (eq (car-safe (nth 1 expr)) '^)
X       (math-equal-int (nth 1 (nth 1 expr)) 10)
X       (or math-living-dangerously
X       (math-known-realp (nth 2 (nth 1 expr))))
X       (nth 2 (nth 1 expr)))
)
X
X
X
(defun math-linear-in (expr term &optional always)
X  (if (math-expr-contains expr term)
X      (let* ((calc-prefer-frac t)
X         (p (math-is-polynomial expr term 1)))
X    (and (cdr p)
X         p))
X    (and always (list expr 0)))
)
X
(defun math-multiple-of (expr term)
X  (let ((p (math-linear-in expr term)))
X    (and p
X     (math-zerop (car p))
X     (nth 1 p)))
)
X
(defun math-integer-plus (expr)
X  (cond ((Math-integerp expr)
X     (list 0 expr))
X    ((and (memq (car expr) '(+ -))
X          (Math-integerp (nth 1 expr)))
X     (list (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))
X           (nth 1 expr)))
X    ((and (memq (car expr) '(+ -))
X          (Math-integerp (nth 2 expr)))
X     (list (nth 1 expr)
X           (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr)))))
X    (t nil))   ; not perfect, but it'll do
)
X
(defun math-is-linear (expr &optional always)
X  (let ((offset nil)
X    (coef nil))
X    (if (eq (car-safe expr) '+)
X    (if (Math-objectp (nth 1 expr))
X        (setq offset (nth 1 expr)
X          expr (nth 2 expr))
X      (if (Math-objectp (nth 2 expr))
X          (setq offset (nth 2 expr)
X            expr (nth 1 expr))))
X      (if (eq (car-safe expr) '-)
X      (if (Math-objectp (nth 1 expr))
X          (setq offset (nth 1 expr)
X            expr (math-neg (nth 2 expr)))
X        (if (Math-objectp (nth 2 expr))
X        (setq offset (math-neg (nth 2 expr))
X              expr (nth 1 expr))))))
X    (setq coef (math-is-multiple expr always))
X    (if offset
X    (list offset (or (car coef) 1) (or (nth 1 coef) expr))
X      (if coef
X      (cons 0 coef))))
)
X
(defun math-is-multiple (expr &optional always)
X  (or (if (eq (car-safe expr) '*)
X      (if (Math-objectp (nth 1 expr))
X          (list (nth 1 expr) (nth 2 expr)))
X    (if (eq (car-safe expr) '/)
X        (if (and (Math-objectp (nth 1 expr))
X             (not (math-equal-int (nth 1 expr) 1)))
X        (list (nth 1 expr) (math-div 1 (nth 2 expr)))
X          (if (Math-objectp (nth 2 expr))
X          (list (math-div 1 (nth 2 expr)) (nth 1 expr))
X        (let ((res (math-is-multiple (nth 1 expr))))
X          (if res
X              (list (car res)
X                (math-div (nth 2 (nth 1 expr)) (nth 2 expr)))
X            (setq res (math-is-multiple (nth 2 expr)))
X            (if res
X            (list (math-div 1 (car res))
X                  (math-div (nth 1 expr)
X                    (nth 2 (nth 2 expr)))))))))
X      (if (eq (car-safe expr) 'neg)
X          (list -1 (nth 1 expr)))))
X      (if (Math-objvecp expr)
X      (and (eq always 1)
X           (list expr 1))
X    (and always
X         (list 1 expr))))
)
X
(defun calcFunc-lin (expr &optional var)
X  (if var
X      (let ((res (math-linear-in expr var t)))
X    (or res (math-reject-arg expr "Linear term expected"))
X    (list 'vec (car res) (nth 1 res) var))
X    (let ((res (math-is-linear expr t)))
X      (or res (math-reject-arg expr "Linear term expected"))
X      (cons 'vec res)))
)
X
(defun calcFunc-linnt (expr &optional var)
X  (if var
X      (let ((res (math-linear-in expr var)))
X    (or res (math-reject-arg expr "Linear term expected"))
X    (list 'vec (car res) (nth 1 res) var))
X    (let ((res (math-is-linear expr)))
X      (or res (math-reject-arg expr "Linear term expected"))
X      (cons 'vec res)))
)
X
(defun calcFunc-islin (expr &optional var)
X  (if (and (Math-objvecp expr) (not var))
X      0
X    (calcFunc-lin expr var)
X    1)
)
X
(defun calcFunc-islinnt (expr &optional var)
X  (if (Math-objvecp expr)
X      0
X    (calcFunc-linnt expr var)
X    1)
)
X
X
X
X
;;; Simple operations on expressions.
X
;;; Return number of ocurrences of thing in expr, or nil if none.
(defun math-expr-contains-count (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-count
X                   (car expr) thing) 0))))
X       (and (> num 0)
X        num))))
)
X
(defun math-expr-contains (expr thing)
X  (cond ((equal expr thing) 1)
X    ((Math-primp expr) nil)
X    (t
X     (while (and (setq expr (cdr expr))
X             (not (math-expr-contains (car expr) thing))))
X     expr))
)
X
;;; Return non-nil if any variable of thing occurs in expr.
(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
;;; Substitute all occurrences of old for new in expr (non-destructive).
(defun math-expr-subst (expr old new)
X  (math-expr-subst-rec expr)
)
(fset 'calcFunc-subst (symbol-function 'math-expr-subst))
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
;;; Various measures of the size of an expression.
(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
(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
;;; Polynomial operations (to support the integrator and solve-for).
X
(defun calcFunc-collect (expr base)
X  (let ((p (math-is-polynomial expr base 50 t)))
X    (if (cdr p)
X    (math-normalize   ; fix selection bug
X     (math-build-polynomial-expr p base))
X      expr))
)
X
;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...),
;;; else return nil if not in polynomial form.  If "loose", coefficients
;;; may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x.
(defun math-is-polynomial (expr var &optional degree loose)
X  (let* ((math-poly-base-variable (if loose
X                      (if (eq loose 'gen) var '(var XXX XXX))
X                    math-poly-base-variable))
X     (poly (math-is-poly-rec expr math-poly-neg-powers)))
X    (and (or (null degree)
X         (<= (length poly) (1+ degree)))
X     poly))
)
X
(defun math-is-poly-rec (expr negpow)
X  (math-poly-simplify
X   (or (cond ((or (equal expr var)
X          (eq (car-safe expr) '^))
X          (let ((pow 1)
X            (expr expr))
X        (or (equal expr var)
X            (setq pow (nth 2 expr)
X              expr (nth 1 expr)))
X        (or (eq math-poly-mult-powers 1)
X            (setq pow (let ((m (math-is-multiple pow 1)))
X                (and (eq (car-safe (car m)) 'cplx)
X                     (Math-zerop (nth 1 (car m)))
X                     (setq m (list (nth 2 (car m))
X                           (math-mul (nth 1 m)
X                                 '(var i var-i)))))
X                (and (if math-poly-mult-powers
X                     (equal math-poly-mult-powers
X                        (nth 1 m))
X                       (setq math-poly-mult-powers (nth 1 m)))
X                     (or (equal expr var)
X                     (eq math-poly-mult-powers 1))
X                     (car m)))))
X        (if (consp pow)
X            (progn
X              (setq pow (math-to-simple-fraction pow))
X              (and (eq (car-safe pow) 'frac)
X               math-poly-frac-powers
X               (equal expr var)
X               (setq math-poly-frac-powers
X                 (calcFunc-lcm math-poly-frac-powers
X                           (nth 2 pow))))))
X        (or (memq math-poly-frac-powers '(1 nil))
X            (setq pow (math-mul pow math-poly-frac-powers)))
X        (if (integerp pow)
X            (if (and (= pow 1)
X                 (equal expr var))
X            (list 0 1)
X              (if (natnump pow)
X              (let ((p1 (if (equal expr var)
X                    (list 0 1)
X                      (math-is-poly-rec expr nil)))
X                (n pow)
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            (and negpow
X                 (math-is-poly-rec expr nil)
X                 (setq math-poly-neg-powers
X                   (cons (math-pow expr (- pow))
X                     math-poly-neg-powers))
X                 (list (list '^ expr pow))))))))
X         ((Math-objectp expr)
X          (list expr))
X         ((memq (car expr) '(+ -))
X          (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
X        (and p1
X             (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
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) negpow)))
X         ((eq (car expr) '*)
X          (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
X        (and p1
X             (let ((p2 (math-is-poly-rec (nth 2 expr) negpow)))
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 (or (not (math-poly-depends (nth 2 expr) var))
X               (and negpow
X                (math-is-poly-rec (nth 2 expr) nil)
X                (setq math-poly-neg-powers
X                  (cons (nth 2 expr) math-poly-neg-powers))))
X           (not (Math-zerop (nth 2 expr)))
X           (let ((p1 (math-is-poly-rec (nth 1 expr) negpow)))
X             (mapcar (function (lambda (x) (math-div x (nth 2 expr))))
X                 p1))))
X         ((and (eq (car expr) 'calcFunc-exp)
X           (equal var '(var e var-e)))
X          (math-is-poly-rec (list '^ var (nth 1 expr)) negpow))
X         ((and (eq (car expr) 'calcFunc-sqrt)
X           math-poly-frac-powers)
X          (math-is-poly-rec (list '^ (nth 1 expr) '(frac 1 2)) negpow))
X         (t nil))
X       (and (or (not (math-poly-depends expr var))
X        loose)
X        (not (eq (car expr) 'vec))
X        (list expr))))
)
X
;;; Check if expr is a polynomial in var; if so, return its degree.
(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)
X       (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
X        (max p1 p2))))
X    ((eq (car expr) '*)
X     (let ((p1 (math-polynomial-p (nth 1 expr) var))
X           p2)
X       (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var))
X        (+ p1 p2))))
X    ((eq (car expr) 'neg)
X     (math-polynomial-p (nth 1 expr) var))
X    ((and (eq (car expr) '/)
X          (not (math-poly-depends (nth 2 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-poly-depends expr var) nil)
X    (t 0))
)
X
(defun math-poly-depends (expr var)
X  (if math-poly-base-variable
X      (math-expr-contains expr math-poly-base-variable)
X    (math-expr-depends expr var))
)
X
;;; Find the variable (or sub-expression) which is the base of polynomial expr.
(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
(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        (math-polynomial-base-rec (nth 1 mpb-expr)))
X       (and (eq (car mpb-expr) 'calcFunc-exp)
X        (math-polynomial-base-rec '(var e var-e)))
X       (and (or const-ok (math-expr-contains-vars mpb-expr))
X        (funcall mpb-pred mpb-expr)
X        mpb-expr)))
)
X
;;; Return non-nil if expr refers to any variables.
(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
;;; Simplify a polynomial in list form by stripping off high-end zeros.
;;; This always leaves the constant part, i.e., nil->nil and nonnil->nonnil.
(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
;;; Compute ac*a + bc*b for polynomials in list form a, b and
;;; coefficients ac, bc.  Result may be unsimplified.
(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
(defun math-poly-zerop (a)
X  (or (null a)
X      (and (null (cdr a)) (Math-zerop (car a))))
)
X
;;; Multiply two polynomials in list form.
(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
;;; Build an expression from a polynomial list.
(defun math-build-polynomial-expr (p var)
X  (if p
X      (if (Math-numberp var)
X      (math-with-extra-prec 1
X        (let* ((rp (reverse p))
X           (accum (car rp)))
X          (while (setq rp (cdr rp))
X        (setq accum (math-add (car rp) (math-mul accum var))))
X          accum))
X    (let* ((rp (reverse p))
X           (n (1- (length rp)))
X           (accum (math-mul (car rp) (math-pow var n)))
X           term)
X      (while (setq rp (cdr rp))
X        (setq n (1- n))
X        (or (math-zerop (car rp))
X        (setq accum (list (if (math-looks-negp (car rp)) '- '+)
X                  accum
X                  (math-mul (if (math-looks-negp (car rp))
X                        (math-neg (car rp))
X                          (car rp))
X                        (math-pow var n))))))
X      accum))
X    0)
)
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
SHAR_EOF
echo 'File calc-alg.el is complete' &&
chmod 0644 calc-alg.el ||
echo 'restore of calc-alg.el failed'
Wc_c="`wc -c < 'calc-alg.el'`"
test 53736 -eq "$Wc_c" ||
    echo 'calc-alg.el: original size 53736, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-arith.el ==============
if test -f 'calc-arith.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-arith.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-arith.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-arith.el' &&
;; Calculator for GNU Emacs, part II [calc-arith.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
X
;; This file is part of GNU Emacs.
X
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.
X
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.
X
X
X
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
X
(require 'calc-macs)
X
(defun calc-Need-calc-arith () nil)
X
X
;;; Arithmetic.
X
(defun calc-min (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "min" 'calcFunc-min arg '(var inf var-inf)))
)
X
(defun calc-max (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "max" 'calcFunc-max arg '(neg (var inf var-inf))))
)
X
(defun calc-abs (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "abs" 'calcFunc-abs arg))
)
X
X
(defun calc-idiv (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "\\" 'calcFunc-idiv arg 1))
)
X
X
(defun calc-floor (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (if (calc-is-inverse)
X       (if (calc-is-hyperbolic)
X       (calc-unary-op "ceil" 'calcFunc-fceil arg)
X     (calc-unary-op "ceil" 'calcFunc-ceil arg))
X     (if (calc-is-hyperbolic)
X     (calc-unary-op "flor" 'calcFunc-ffloor arg)
X       (calc-unary-op "flor" 'calcFunc-floor arg))))
)
X
(defun calc-ceiling (arg)
X  (interactive "P")
X  (calc-invert-func)
X  (calc-floor arg)
)
X
(defun calc-round (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (if (calc-is-inverse)
X       (if (calc-is-hyperbolic)
X       (calc-unary-op "trnc" 'calcFunc-ftrunc arg)
X     (calc-unary-op "trnc" 'calcFunc-trunc arg))
X     (if (calc-is-hyperbolic)
X     (calc-unary-op "rond" 'calcFunc-fround arg)
X       (calc-unary-op "rond" 'calcFunc-round arg))))
)
X
(defun calc-trunc (arg)
X  (interactive "P")
X  (calc-invert-func)
X  (calc-round arg)
)
X
(defun calc-mant-part (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "mant" 'calcFunc-mant arg))
)
X
(defun calc-xpon-part (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "xpon" 'calcFunc-xpon arg))
)
X
(defun calc-scale-float (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "scal" 'calcFunc-scf arg))
)
X
(defun calc-abssqr (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "absq" 'calcFunc-abssqr arg))
)
X
(defun calc-sign (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-unary-op "sign" 'calcFunc-sign arg))
)
X
(defun calc-increment (arg)
X  (interactive "p")
X  (calc-wrapper
X   (calc-enter-result 1 "incr" (list 'calcFunc-incr (calc-top-n 1) arg)))
)
X
(defun calc-decrement (arg)
X  (interactive "p")
X  (calc-wrapper
X   (calc-enter-result 1 "decr" (list 'calcFunc-decr (calc-top-n 1) arg)))
)
X
X
(defun math-abs-approx (a)
X  (cond ((Math-negp a)
X     (math-neg a))
X    ((Math-anglep a)
X     a)
X    ((eq (car a) 'cplx)
X     (math-add (math-abs (nth 1 a)) (math-abs (nth 2 a))))
X    ((eq (car a) 'polar)
X     (nth 1 a))
X    ((eq (car a) 'sdev)
X     (math-abs-approx (nth 1 a)))
X    ((eq (car a) 'intv)
X     (math-max (math-abs (nth 2 a)) (math-abs (nth 3 a))))
X    ((eq (car a) 'date)
X     a)
X    ((eq (car a) 'vec)
X     (math-reduce-vec 'math-add-abs-approx a))
X    ((eq (car a) 'calcFunc-abs)
X     (car a))
X    (t a))
)
X
(defun math-add-abs-approx (a b)
X  (math-add (math-abs-approx a) (math-abs-approx b))
)
X
X
;;;; Declarations.
X
(setq math-decls-cache-tag nil)
(setq math-decls-cache nil)
(setq math-decls-all nil)
X
;;; Math-decls-cache is an a-list where each entry is a list of the form:
;;;   (VAR TYPES RANGE)
;;; where VAR is a variable name (with var- prefix) or function name;
;;;       TYPES is a list of type symbols (any, int, frac, ...)
;;;      RANGE is a sorted vector of intervals describing the range.
X
(defun math-setup-declarations ()
X  (or (eq math-decls-cache-tag (calc-var-value 'var-Decls))
X      (let ((p (calc-var-value 'var-Decls))
X        vec type range)
X    (setq math-decls-cache-tag p
X          math-decls-cache nil)
X    (and (eq (car-safe p) 'vec)
X         (while (setq p (cdr p))
X           (and (eq (car-safe (car p)) 'vec)
X            (setq vec (nth 2 (car p)))
X            (condition-case err
X            (let ((v (nth 1 (car p))))
X              (setq type nil range nil)
X              (or (eq (car-safe vec) 'vec)
X                  (setq vec (list 'vec vec)))
X              (while (and (setq vec (cdr vec))
X                      (not (Math-objectp (car vec))))
X                (and (eq (car-safe (car vec)) 'var)
X                 (let ((st (assq (nth 1 (car vec))
X                         math-super-types)))
X                   (cond (st (setq type (append type st)))
X                     ((eq (nth 1 (car vec)) 'pos)
X                      (setq type (append type
X                                 '(real number))
X                        range
X                        '(intv 1 0 (var inf var-inf))))
X                     ((eq (nth 1 (car vec)) 'nonneg)
X                      (setq type (append type
X                                 '(real number))
X                        range
X                        '(intv 3 0
X                               (var inf var-inf))))))))
X              (if vec
X                  (setq type (append type '(real number))
X                    range (math-prepare-set (cons 'vec vec))))
X              (setq type (list type range))
X              (or (eq (car-safe v) 'vec)
X                  (setq v (list 'vec v)))
X              (while (setq v (cdr v))
X                (if (or (eq (car-safe (car v)) 'var)
X                    (not (Math-primp (car v))))
X                (setq math-decls-cache
X                      (cons (cons (if (eq (car (car v)) 'var)
X                              (nth 2 (car v))
X                            (car (car v)))
X                          type)
X                        math-decls-cache)))))
X              (error nil)))))
X    (setq math-decls-all (assq 'var-All math-decls-cache))))
)
X
(defvar math-super-types
X  '( ( int     numint rat real number )
X     ( numint  real number )
X     ( frac    rat real number )
X     ( rat     real number )
X     ( float   real number )
X     ( real    number )
X     ( number  )
X     ( scalar  )
X     ( matrix  vector )
X     ( vector )
X     ( const )
))
X
X
(defun math-known-scalarp (a &optional assume-scalar)
X  (math-setup-declarations)
X  (if (if calc-matrix-mode
X      (eq calc-matrix-mode 'scalar)
X    assume-scalar)
X      (not (math-check-known-matrixp a))
X    (math-check-known-scalarp a))
)
X
(defun math-known-matrixp (a)
X  (and (not (Math-scalarp a))
X       (not (math-known-scalarp a t)))
)
X
;;; Try to prove that A is a scalar (i.e., a non-vector).
(defun math-check-known-scalarp (a)
X  (cond ((Math-objectp a) t)
X    ((memq (car a) math-scalar-functions)
X     t)
X    ((memq (car a) math-real-scalar-functions)
X     t)
X    ((memq (car a) math-scalar-if-args-functions)
X     (while (and (setq a (cdr a))
X             (math-check-known-scalarp (car a))))
X     (null a))
X    ((eq (car a) '^)
X     (math-check-known-scalarp (nth 1 a)))
X    ((math-const-var a) t)
X    (t
X     (let ((decl (if (eq (car a) 'var)
X             (or (assq (nth 2 a) math-decls-cache)
X                 math-decls-all)
X               (assq (car a) math-decls-cache))))
X       (memq 'scalar (nth 1 decl)))))
)
X
;;; Try to prove that A is *not* a scalar.
(defun math-check-known-matrixp (a)
X  (cond ((Math-objectp a) nil)
X    ((memq (car a) math-nonscalar-functions)
X     t)
X    ((memq (car a) math-scalar-if-args-functions)
X     (while (and (setq a (cdr a))
X             (not (math-check-known-matrixp (car a)))))
X     a)
X    ((eq (car a) '^)
X     (math-check-known-matrixp (nth 1 a)))
X    ((math-const-var a) nil)
X    (t
X     (let ((decl (if (eq (car a) 'var)
X             (or (assq (nth 2 a) math-decls-cache)
X                 math-decls-all)
X               (assq (car a) math-decls-cache))))
X       (memq 'vector (nth 1 decl)))))
)
X
X
;;; Try to prove that A is a real (i.e., not complex).
(defun math-known-realp (a)
X  (< (math-possible-signs a) 8)
)
X
;;; Try to prove that A is real and positive.
(defun math-known-posp (a)
X  (eq (math-possible-signs a) 4)
)
X
;;; Try to prove that A is real and negative.
(defun math-known-negp (a)
X  (eq (math-possible-signs a) 1)
)
X
;;; Try to prove that A is real and nonnegative.
(defun math-known-nonnegp (a)
X  (memq (math-possible-signs a) '(2 4 6))
)
X
;;; Try to prove that A is real and nonpositive.
(defun math-known-nonposp (a)
X  (memq (math-possible-signs a) '(1 2 3))
)
X
;;; Try to prove that A is nonzero.
(defun math-known-nonzerop (a)
X  (memq (math-possible-signs a) '(1 4 5 8 9 12 13))
)
X
;;; Return true if A is negative, or looks negative but we don't know.
(defun math-guess-if-neg (a)
X  (let ((sgn (math-possible-signs a)))
X    (if (memq sgn '(1 3))
X    t
X      (if (memq sgn '(2 4 6))
X      nil
X    (math-looks-negp a))))
)
X
;;; Find the possible signs of A, assuming A is a number of some kind.
;;; Returns an integer with bits:  1  may be negative,
;;;                   2  may be zero,
;;;                   4  may be positive,
;;;                   8  may be nonreal.
X
(defun math-possible-signs (a &optional origin)
X  (cond ((Math-objectp a)
X     (if origin (setq a (math-sub a origin)))
X     (cond ((Math-posp a) 4)
X           ((Math-negp a) 1)
X           ((Math-zerop a) 2)
X           ((eq (car a) 'intv)
X        (cond ((Math-zerop (nth 2 a)) 6)
X              ((Math-zerop (nth 3 a)) 3)
X              (t 7)))
X           ((eq (car a) 'sdev)
X        (if (math-known-realp (nth 1 a)) 7 15))
X           (t 8)))
X    ((memq (car a) '(+ -))
X     (cond ((Math-realp (nth 1 a))
X        (if (eq (car a) '-)
X            (math-neg-signs
X             (math-possible-signs (nth 2 a)
X                      (if origin
X                          (math-add origin (nth 1 a))
X                        (nth 1 a))))
X          (math-possible-signs (nth 2 a)
X                       (if origin
X                       (math-sub origin (nth 1 a))
X                     (math-neg (nth 1 a))))))
X           ((Math-realp (nth 2 a))
X        (let ((org (if (eq (car a) '-)
X                   (nth 2 a)
X                 (math-neg (nth 2 a)))))
X          (math-possible-signs (nth 1 a)
X                       (if origin
X                       (math-add origin org)
X                     org))))
X           (t
X        (let ((s1 (math-possible-signs (nth 1 a) origin))
X              (s2 (math-possible-signs (nth 2 a))))
X          (if (eq (car a) '-) (setq s2 (math-neg-signs s2)))
X          (cond ((eq s1 s2) s1)
X            ((eq s1 2) s2)
X            ((eq s2 2) s1)
X            ((>= s1 8) 15)
X            ((>= s2 8) 15)
X            ((and (eq s1 4) (eq s2 6)) 4)
X            ((and (eq s2 4) (eq s1 6)) 4)
X            ((and (eq s1 1) (eq s2 3)) 1)
X            ((and (eq s2 1) (eq s1 3)) 1)
X            (t 7))))))
X    ((eq (car a) 'neg)
X     (math-neg-signs (math-possible-signs
X              (nth 1 a)
X              (and origin (math-neg origin)))))
X    ((and origin (Math-zerop origin) (setq origin nil)
X          nil))
X    ((and (or (eq (car a) '*)
X          (and (eq (car a) '/) origin))
X          (Math-realp (nth 1 a)))
X     (let ((s (if (eq (car a) '*)
X              (if (Math-zerop (nth 1 a))
X              (math-possible-signs 0 origin)
X            (math-possible-signs (nth 2 a)
X                         (math-div (or origin 0)
X                               (nth 1 a))))
X            (math-neg-signs
X             (math-possible-signs (nth 2 a)
X                      (math-div (nth 1 a)
X                            origin))))))
X       (if (Math-negp (nth 1 a)) (math-neg-signs s) s)))
X    ((and (memq (car a) '(* /)) (Math-realp (nth 2 a)))
X     (let ((s (math-possible-signs (nth 1 a)
X                       (if (eq (car a) '*)
X                       (math-mul (or origin 0) (nth 2 a))
X                     (math-div (or origin 0) (nth 2 a))))))
X       (if (Math-negp (nth 2 a)) (math-neg-signs s) s)))
X    ((eq (car a) 'vec)
X     (let ((signs 0))
X       (while (and (setq a (cdr a)) (< signs 15))
X         (setq signs (logior signs (math-possible-signs
X                    (car a) origin))))
X       signs))
X    (t (let ((sign
X          (cond
X           ((memq (car a) '(* /))
X            (let ((s1 (math-possible-signs (nth 1 a)))
X              (s2 (math-possible-signs (nth 2 a))))
X              (cond ((>= s1 8) 15)
X                ((>= s2 8) 15)
X                ((and (eq (car a) '/) (memq s2 '(2 3 6 7))) 15)
X                (t
X                 (logior (if (memq s1 '(4 5 6 7)) s2 0)
X                     (if (memq s1 '(2 3 6 7)) 2 0)
X                     (if (memq s1 '(1 3 5 7))
X                     (math-neg-signs s2) 0))))))
X           ((eq (car a) '^)
X            (let ((s1 (math-possible-signs (nth 1 a)))
X              (s2 (math-possible-signs (nth 2 a))))
X              (cond ((>= s1 8) 15)
X                ((>= s2 8) 15)
X                ((eq s1 4) 4)
X                ((eq s1 2) (if (eq s2 4) 2 15))
X                ((eq s2 2) (if (memq s1 '(1 5)) 2 15))
X                ((Math-integerp (nth 2 a))
X                 (if (math-evenp (nth 2 a))
X                 (if (memq s1 '(3 6 7)) 6 4)
X                   s1))
X                ((eq s1 6) (if (eq s2 4) 6 15))
X                (t 7))))
X           ((eq (car a) '%)
X            (let ((s2 (math-possible-signs (nth 2 a))))
X              (cond ((>= s2 8) 7)
X                ((eq s2 2) 2)
X                ((memq s2 '(4 6)) 6)
X                ((memq s2 '(1 3)) 3)
X                (t 7))))
X           ((and (memq (car a) '(calcFunc-abs calcFunc-abssqr))
X             (= (length a) 2))
X            (let ((s1 (math-possible-signs (nth 1 a))))
X              (cond ((eq s1 2) 2)
X                ((memq s1 '(1 4 5)) 4)
X                (t 6))))
X           ((and (eq (car a) 'calcFunc-exp) (= (length a) 2))
X            (let ((s1 (math-possible-signs (nth 1 a))))
X              (if (>= s1 8)
X              15
X            (if (or (not origin) (math-negp origin))
X                4
X              (setq origin (math-sub (or origin 0) 1))
X              (if (Math-zerop origin) (setq origin nil))
X              s1))))
X           ((or (and (memq (car a) '(calcFunc-ln calcFunc-log10))
X                 (= (length a) 2))
X            (and (eq (car a) 'calcFunc-log)
X                 (= (length a) 3)
X                 (math-known-posp (nth 2 a))))
X            (if (math-known-nonnegp (nth 1 a))
X            (math-possible-signs (nth 1 a) 1)
X              15))
X           ((and (eq (car a) 'calcFunc-sqrt) (= (length a) 2))
X            (let ((s1 (math-possible-signs (nth 1 a))))
X              (if (memq s1 '(2 4 6)) s1 15)))
X           ((memq (car a) math-nonnegative-functions) 6)
X           ((memq (car a) math-positive-functions) 4)
X           ((memq (car a) math-real-functions) 7)
X           ((memq (car a) math-real-scalar-functions) 7)
X           ((and (memq (car a) math-real-if-arg-functions)
X             (= (length a) 2))
X            (if (math-known-realp (nth 1 a)) 7 15)))))
X         (cond (sign
X            (if origin
X            (+ (logand sign 8)
X               (if (Math-posp origin)
X                   (if (memq sign '(1 2 3 8 9 10 11)) 1 7)
X                 (if (memq sign '(2 4 6 8 10 12 14)) 4 7)))
X              sign))
X           ((math-const-var a)
X            (cond ((eq (nth 2 a) 'var-pi)
X               (if origin
X                   (math-possible-signs (math-pi) origin)
X                 4))
X              ((eq (nth 2 a) 'var-e)
X               (if origin
X                   (math-possible-signs (math-e) origin)
X                 4))
X              ((eq (nth 2 a) 'var-inf) 4)
X              ((eq (nth 2 a) 'var-uinf) 13)
X              ((eq (nth 2 a) 'var-i) 8)
X              (t 15)))
X           (t
X            (math-setup-declarations)
X            (let ((decl (if (eq (car a) 'var)
X                    (or (assq (nth 2 a) math-decls-cache)
X                    math-decls-all)
X                  (assq (car a) math-decls-cache))))
X              (if (and origin
X                   (memq 'int (nth 1 decl))
X                   (not (Math-num-integerp origin)))
X              5
X            (if (nth 2 decl)
X                (math-possible-signs (nth 2 decl) origin)
X              (if (memq 'real (nth 1 decl))
X                  7
X                15)))))))))
)
X
(defun math-neg-signs (s1)
X  (if (>= s1 8)
X      (+ 8 (math-neg-signs (- s1 8)))
X    (+ (if (memq s1 '(1 3 5 7)) 4 0)
X       (if (memq s1 '(2 3 6 7)) 2 0)
X       (if (memq s1 '(4 5 6 7)) 1 0)))
)
X
X
;;; Try to prove that A is an integer.
(defun math-known-integerp (a)
X  (eq (math-possible-types a) 1)
)
X
(defun math-known-num-integerp (a)
X  (<= (math-possible-types a t) 3)
)
X
(defun math-known-imagp (a)
X  (= (math-possible-types a) 16)
)
X
X
;;; Find the possible types of A.
;;; Returns an integer with bits:  1  may be integer.
;;;                   2  may be integer-valued float.
;;;                   4  may be fraction.
;;;                   8  may be non-integer-valued float.
;;;                  16  may be imaginary.
;;;                  32  may be non-real, non-imaginary.
;;; Real infinities count as integers for the purposes of this function.
(defun math-possible-types (a &optional num)
X  (cond ((Math-objectp a)
X     (cond ((Math-integerp a) (if num 3 1))
X           ((Math-messy-integerp a) (if num 3 2))
X           ((eq (car a) 'frac) (if num 12 4))
X           ((eq (car a) 'float) (if num 12 8))
X           ((eq (car a) 'intv)
X        (if (equal (nth 2 a) (nth 3 a))
X            (math-possible-types (nth 2 a))
X          15))
X           ((eq (car a) 'sdev)
X        (if (math-known-realp (nth 1 a)) 15 63))
X           ((eq (car a) 'cplx)
X        (if (math-zerop (nth 1 a)) 16 32))
X           ((eq (car a) 'polar)
X        (if (or (Math-equal (nth 2 a) (math-quarter-circle nil))
X            (Math-equal (nth 2 a)
X                    (math-neg (math-quarter-circle nil))))
X            16 48))
X           (t 63)))
X    ((eq (car a) '/)
X     (let* ((t1 (math-possible-types (nth 1 a) num))
X        (t2 (math-possible-types (nth 2 a) num))
X        (t12 (logior t1 t2)))
X       (if (< t12 16)
X           (if (> (logand t12 10) 0)
X           10
X         (if (or (= t1 4) (= t2 4) calc-prefer-frac)
X             5
X           15))
X         (if (< t12 32)
X         (if (= t1 16)
X             (if (= t2 16) 15
X               (if (< t2 16) 16 31))
X           (if (= t2 16)
X               (if (< t1 16) 16 31)
X             31))
X           63))))
X    ((memq (car a) '(+ - * %))
X     (let* ((t1 (math-possible-types (nth 1 a) num))
X        (t2 (math-possible-types (nth 2 a) num))
X        (t12 (logior t1 t2)))
X       (if (eq (car a) '%)
X           (setq t1 (logand t1 15) t2 (logand t2 15) t12 (logand t12 15)))
X       (if (< t12 16)
X           (let ((mask (if (<= t12 3)
X                   1
X                 (if (and (or (and (<= t1 3) (= (logand t2 3) 0))
X                      (and (<= t2 3) (= (logand t1 3) 0)))
X                      (memq (car a) '(+ -)))
X                 4
X                   5))))
X         (if num
X             (* mask 3)
X           (logior (if (and (> (logand t1 5) 0) (> (logand t2 5) 0))
X                   mask 0)
X               (if (> (logand t12 10) 0)
X                   (* mask 2) 0))))
X         (if (< t12 32)
X         (if (eq (car a) '*)
X             (if (= t1 16)
X             (if (= t2 16) 15
X               (if (< t2 16) 16 31))
X               (if (= t2 16)
X               (if (< t1 16) 16 31)
X             31))
X           (if (= t12 16) 16
X             (if (or (and (= t1 16) (< t2 16))
X                 (and (= t2 16) (< t1 16))) 32 63)))
X           63))))
X    ((eq (car a) 'neg)
X     (math-possible-types (nth 1 a)))
X    ((eq (car a) '^)
X     (let* ((t1 (math-possible-types (nth 1 a) num))
X        (t2 (math-possible-types (nth 2 a) num))
X        (t12 (logior t1 t2)))
X       (if (and (<= t2 3) (math-known-nonnegp (nth 2 a)) (< t1 16))
X           (let ((mask (logior (if (> (logand t1 3) 0) 1 0)
X                   (logand t1 4)
X                   (if (> (logand t1 12) 0) 5 0))))
X         (if num
X             (* mask 3)
X           (logior (if (and (> (logand t1 5) 0) (> (logand t2 5) 0))
X                   mask 0)
X               (if (> (logand t12 10) 0)
X                   (* mask 2) 0))))
X         (if (and (math-known-nonnegp (nth 1 a))
X              (math-known-posp (nth 2 a)))
X         15
X           63))))
X    ((eq (car a) 'calcFunc-sqrt)
X     (let ((t1 (math-possible-signs (nth 1 a))))
X       (logior (if (> (logand t1 2) 0) 3 0)
X           (if (> (logand t1 1) 0) 16 0)
X           (if (> (logand t1 4) 0) 15 0)
X           (if (> (logand t1 8) 0) 32 0))))
X    ((eq (car a) 'vec)
X     (let ((types 0))
X       (while (and (setq a (cdr a)) (< types 63))
X         (setq types (logior types (math-possible-types (car a) t))))
X       types))
X    ((or (memq (car a) math-integer-functions)
X         (and (memq (car a) math-rounding-functions)
X          (math-known-nonnegp (or (nth 2 a) 0))))
X     1)
X    ((or (memq (car a) math-num-integer-functions)
X         (and (memq (car a) math-float-rounding-functions)
X          (math-known-nonnegp (or (nth 2 a) 0))))
X     2)
X    ((eq (car a) 'calcFunc-frac)
X     5)
X    ((and (eq (car a) 'calcFunc-float) (= (length a) 2))
X     (let ((t1 (math-possible-types (nth 1 a))))
X       (logior (if (> (logand t1 3) 0) 2 0)
X           (if (> (logand t1 12) 0) 8 0)
X           (logand t1 48))))
X    ((and (memq (car a) '(calcFunc-abs calcFunc-abssqr))
X          (= (length a) 2))
X     (let ((t1 (math-possible-types (nth 1 a))))
X       (if (>= t1 16)
X           15
X         t1)))
X    ((math-const-var a)
X     (cond ((memq (nth 2 a) '(var-e var-pi var-phi var-gamma)) 8)
X           ((eq (nth 2 a) 'var-inf) 1)
X           ((eq (nth 2 a) 'var-i) 16)
X           (t 63)))
X    (t
X     (math-setup-declarations)
X     (let ((decl (if (eq (car a) 'var)
X             (or (assq (nth 2 a) math-decls-cache)
X                 math-decls-all)
X               (assq (car a) math-decls-cache))))
X       (cond ((memq 'int (nth 1 decl))
X          1)
X         ((memq 'numint (nth 1 decl))
X          3)
X         ((memq 'frac (nth 1 decl))
X          4)
X         ((memq 'rat (nth 1 decl))
X          5)
X         ((memq 'float (nth 1 decl))
X          10)
X         ((nth 2 decl)
X          (math-possible-types (nth 2 decl)))
X         ((memq 'real (nth 1 decl))
X          15)
X         (t 63)))))
)
X
(defun math-known-evenp (a)
X  (cond ((Math-integerp a)
X     (math-evenp a))
X    ((Math-messy-integerp a)
X     (or (> (nth 2 a) 0)
X         (math-evenp (math-trunc a))))
X    ((eq (car a) '*)
X     (if (math-known-evenp (nth 1 a))
X         (math-known-num-integerp (nth 2 a))
X       (if (math-known-num-integerp (nth 1 a))
X           (math-known-evenp (nth 2 a)))))
X    ((memq (car a) '(+ -))
X     (or (and (math-known-evenp (nth 1 a))
X          (math-known-evenp (nth 2 a)))
X         (and (math-known-oddp (nth 1 a))
X          (math-known-oddp (nth 2 a)))))
X    ((eq (car a) 'neg)
X     (math-known-evenp (nth 1 a))))
)
X
(defun math-known-oddp (a)
X  (cond ((Math-integerp a)
X     (math-oddp a))
X    ((Math-messy-integerp a)
X     (and (<= (nth 2 a) 0)
X          (math-oddp (math-trunc a))))
X    ((memq (car a) '(+ -))
X     (or (and (math-known-evenp (nth 1 a))
X          (math-known-oddp (nth 2 a)))
X         (and (math-known-oddp (nth 1 a))
X          (math-known-evenp (nth 2 a)))))
X    ((eq (car a) 'neg)
X     (math-known-oddp (nth 1 a))))
)
X
X
(defun calcFunc-dreal (expr)
X  (let ((types (math-possible-types expr)))
X    (if (< types 16) 1
X      (if (= (logand types 15) 0) 0
X    (math-reject-arg expr 'realp 'quiet))))
)
X
(defun calcFunc-dimag (expr)
X  (let ((types (math-possible-types expr)))
X    (if (= types 16) 1
X      (if (= (logand types 16) 0) 0
X    (math-reject-arg expr "Expected an imaginary number"))))
)
X
(defun calcFunc-dpos (expr)
X  (let ((signs (math-possible-signs expr)))
X    (if (eq signs 4) 1
X      (if (memq signs '(1 2 3)) 0
X    (math-reject-arg expr 'posp 'quiet))))
)
X
(defun calcFunc-dneg (expr)
X  (let ((signs (math-possible-signs expr)))
X    (if (eq signs 1) 1
X      (if (memq signs '(2 4 6)) 0
X    (math-reject-arg expr 'negp 'quiet))))
)
X
(defun calcFunc-dnonneg (expr)
X  (let ((signs (math-possible-signs expr)))
X    (if (memq signs '(2 4 6)) 1
X      (if (eq signs 1) 0
X    (math-reject-arg expr 'posp 'quiet))))
)
X
(defun calcFunc-dnonzero (expr)
X  (let ((signs (math-possible-signs expr)))
X    (if (memq signs '(1 4 5 8 9 12 13)) 1
X      (if (eq signs 2) 0
X    (math-reject-arg expr 'nonzerop 'quiet))))
)
X
(defun calcFunc-dint (expr)
X  (let ((types (math-possible-types expr)))
X    (if (= types 1) 1
X      (if (= (logand types 1) 0) 0
X    (math-reject-arg expr 'integerp 'quiet))))
)
X
(defun calcFunc-dnumint (expr)
X  (let ((types (math-possible-types expr t)))
X    (if (<= types 3) 1
X      (if (= (logand types 3) 0) 0
X    (math-reject-arg expr 'integerp 'quiet))))
)
X
(defun calcFunc-dnatnum (expr)
X  (let ((res (calcFunc-dint expr)))
X    (if (eq res 1)
X    (calcFunc-dnonneg expr)
X      res))
)
X
(defun calcFunc-deven (expr)
X  (if (math-known-evenp expr)
X      1
X    (if (or (math-known-oddp expr)
X        (= (logand (math-possible-types expr) 3) 0))
X    0
X      (math-reject-arg expr "Can't tell if expression is odd or even")))
)
X
(defun calcFunc-dodd (expr)
X  (if (math-known-oddp expr)
X      1
X    (if (or (math-known-evenp expr)
X        (= (logand (math-possible-types expr) 3) 0))
X    0
X      (math-reject-arg expr "Can't tell if expression is odd or even")))
)
X
(defun calcFunc-drat (expr)
X  (let ((types (math-possible-types expr)))
X    (if (memq types '(1 4 5)) 1
X      (if (= (logand types 5) 0) 0
X    (math-reject-arg expr "Rational number expected"))))
)
X
(defun calcFunc-drange (expr)
X  (math-setup-declarations)
X  (let (range)
X    (if (Math-realp expr)
X    (list 'vec expr)
X      (if (eq (car-safe expr) 'intv)
X      expr
X    (if (eq (car-safe expr) 'var)
X        (setq range (nth 2 (or (assq (nth 2 expr) math-decls-cache)
X                   math-decls-all)))
X      (setq range (nth 2 (assq (car-safe expr) math-decls-cache))))
X    (if range
X        (math-clean-set (copy-sequence range))
X      (setq range (math-possible-signs expr))
X      (if (< range 8)
X          (aref [(vec)
X             (intv 2 (neg (var inf var-inf)) 0)
X             (vec 0)
X             (intv 3 (neg (var inf var-inf)) 0)
X             (intv 1 0 (var inf var-inf))
X             (vec (intv 2 (neg (var inf var-inf)) 0)
X              (intv 1 0 (var inf var-inf)))
X             (intv 3 0 (var inf var-inf))
X             (intv 3 (neg (var inf var-inf)) (var inf var-inf))] range)
X        (math-reject-arg expr 'realp 'quiet))))))
)
X
(defun calcFunc-dscalar (a)
X  (if (math-known-scalarp a) 1
X    (if (math-known-matrixp a) 0
X      (math-reject-arg a 'objectp 'quiet)))
)
X
X
;;; The following lists are not exhaustive.
(defvar math-scalar-functions '(calcFunc-det
X                calcFunc-cnorm calcFunc-rnorm
X                calcFunc-vlen calcFunc-vcount
X                calcFunc-vsum calcFunc-vprod
X                calcFunc-vmin calcFunc-vmax
))
X
(defvar math-nonscalar-functions '(vec calcFunc-idn calcFunc-diag
X                       calcFunc-cvec calcFunc-index
X                       calcFunc-trn
X                       | calcFunc-append
X                       calcFunc-cons calcFunc-rcons
X                       calcFunc-tail calcFunc-rhead
))
X
(defvar math-scalar-if-args-functions '(+ - * / neg))
X
(defvar math-real-functions '(calcFunc-arg
X                  calcFunc-re calcFunc-im
X                  calcFunc-floor calcFunc-ceil
X                  calcFunc-trunc calcFunc-round
X                  calcFunc-rounde calcFunc-roundu
X                  calcFunc-ffloor calcFunc-fceil
X                  calcFunc-ftrunc calcFunc-fround
X                  calcFunc-frounde calcFunc-froundu
))
X
(defvar math-positive-functions '(
))
X
(defvar math-nonnegative-functions '(calcFunc-cnorm calcFunc-rnorm
X                     calcFunc-vlen calcFunc-vcount
))
X
(defvar math-real-scalar-functions '(% calcFunc-idiv calcFunc-abs
X                       calcFunc-choose calcFunc-perm
X                       calcFunc-eq calcFunc-neq
X                       calcFunc-lt calcFunc-gt
X                       calcFunc-leq calcFunc-geq
X                       calcFunc-lnot
X                       calcFunc-max calcFunc-min
))
X
(defvar math-real-if-arg-functions '(calcFunc-sin calcFunc-cos
X                     calcFunc-tan calcFunc-arctan
X                     calcFunc-sinh calcFunc-cosh
X                     calcFunc-tanh calcFunc-exp
X                     calcFunc-gamma calcFunc-fact
))
X
(defvar math-integer-functions '(calcFunc-idiv
X                 calcFunc-isqrt calcFunc-ilog
X                 calcFunc-vlen calcFunc-vcount
))
X
(defvar math-num-integer-functions '(
))
X
(defvar math-rounding-functions '(calcFunc-floor
X                  calcFunc-ceil
X                  calcFunc-round calcFunc-trunc
X                  calcFunc-rounde calcFunc-roundu
))
X
(defvar math-float-rounding-functions '(calcFunc-ffloor
X                    calcFunc-fceil
X                    calcFunc-fround calcFunc-ftrunc
X                    calcFunc-frounde calcFunc-froundu
))
X
(defvar math-integer-if-args-functions '(+ - * % neg calcFunc-abs
X                       calcFunc-min calcFunc-max
X                       calcFunc-choose calcFunc-perm
))
X
X
;;;; Arithmetic.
X
(defun calcFunc-neg (a)
X  (math-normalize (list 'neg a))
)
X
(defun math-neg-fancy (a)
X  (cond ((eq (car a) 'polar)
X     (list 'polar
X           (nth 1 a)
X           (if (math-posp (nth 2 a))
X           (math-sub (nth 2 a) (math-half-circle nil))
X         (math-add (nth 2 a) (math-half-circle nil)))))
X    ((eq (car a) 'mod)
X     (if (math-zerop (nth 1 a))
X         a
X       (list 'mod (math-sub (nth 2 a) (nth 1 a)) (nth 2 a))))
X    ((eq (car a) 'sdev)
X     (list 'sdev (math-neg (nth 1 a)) (nth 2 a)))
X    ((eq (car a) 'intv)
X     (math-make-intv (aref [0 2 1 3] (nth 1 a))
X             (math-neg (nth 3 a))
X             (math-neg (nth 2 a))))
X    ((and math-simplify-only
X          (not (equal a math-simplify-only)))
X     (list 'neg a))
X    ((eq (car a) '+)
X     (math-sub (math-neg (nth 1 a)) (nth 2 a)))
X    ((eq (car a) '-)
X     (math-sub (nth 2 a) (nth 1 a)))
X    ((and (memq (car a) '(* /))
X          (math-okay-neg (nth 1 a)))
X     (list (car a) (math-neg (nth 1 a)) (nth 2 a)))
X    ((and (memq (car a) '(* /))
X          (math-okay-neg (nth 2 a)))
X     (list (car a) (nth 1 a) (math-neg (nth 2 a))))
X    ((and (memq (car a) '(* /))
X          (or (math-objectp (nth 1 a))
X          (and (eq (car (nth 1 a)) '*)
X               (math-objectp (nth 1 (nth 1 a))))))
X     (list (car a) (math-neg (nth 1 a)) (nth 2 a)))
X    ((and (eq (car a) '/)
X          (or (math-objectp (nth 2 a))
X          (and (eq (car (nth 2 a)) '*)
X               (math-objectp (nth 1 (nth 2 a))))))
X     (list (car a) (nth 1 a) (math-neg (nth 2 a))))
X    ((and (eq (car a) 'var) (memq (nth 2 a) '(var-uinf var-nan)))
X     a)
X    ((eq (car a) 'neg)
X     (nth 1 a))
X    (t (list 'neg a)))
)
X
(defun math-okay-neg (a)
X  (or (math-looks-negp a)
X      (eq (car-safe a) '-))
)
X
(defun math-neg-float (a)
X  (list 'float (Math-integer-neg (nth 1 a)) (nth 2 a))
)
X
X
(defun calcFunc-add (&rest rest)
X  (if rest
X      (let ((a (car rest)))
X    (while (setq rest (cdr rest))
X      (setq a (list '+ a (car rest))))
X    (math-normalize a))
X    0)
)
X
(defun calcFunc-sub (&rest rest)
X  (if rest
X      (let ((a (car rest)))
X    (while (setq rest (cdr rest))
X      (setq a (list '- a (car rest))))
X    (math-normalize a))
X    0)
)
X
(defun math-add-objects-fancy (a b)
X  (cond ((and (Math-numberp a) (Math-numberp b))
X     (let ((aa (math-complex a))
X           (bb (math-complex b)))
X       (math-normalize
X        (let ((res (list 'cplx
X                 (math-add (nth 1 aa) (nth 1 bb))
X                 (math-add (nth 2 aa) (nth 2 bb)))))
X          (if (math-want-polar a b)
X          (math-polar res)
X        res)))))
X    ((or (Math-vectorp a) (Math-vectorp b))
X     (math-map-vec-2 'math-add a b))
X    ((eq (car-safe a) 'sdev)
X     (if (eq (car-safe b) 'sdev)
X         (math-make-sdev (math-add (nth 1 a) (nth 1 b))
X                 (math-hypot (nth 2 a) (nth 2 b)))
X       (and (or (Math-scalarp b)
X            (not (Math-objvecp b)))
X        (math-make-sdev (math-add (nth 1 a) b) (nth 2 a)))))
X    ((and (eq (car-safe b) 'sdev)
X          (or (Math-scalarp a)
X          (not (Math-objvecp a))))
X     (math-make-sdev (math-add a (nth 1 b)) (nth 2 b)))
X    ((eq (car-safe a) 'intv)
X     (if (eq (car-safe b) 'intv)
X         (math-make-intv (logior (logand (nth 1 a) (nth 1 b))
X                     (if (equal (nth 2 a)
X                        '(neg (var inf var-inf)))
X                     (logand (nth 1 a) 2) 0)
X                     (if (equal (nth 2 b)
X                        '(neg (var inf var-inf)))
X                     (logand (nth 1 b) 2) 0)
X                     (if (equal (nth 3 a) '(var inf var-inf))
X                     (logand (nth 1 a) 1) 0)
X                     (if (equal (nth 3 b) '(var inf var-inf))
X                     (logand (nth 1 b) 1) 0))
X                 (math-add (nth 2 a) (nth 2 b))
X                 (math-add (nth 3 a) (nth 3 b)))
X       (and (or (Math-anglep b)
X            (eq (car b) 'date)
X            (not (Math-objvecp b)))
X        (math-make-intv (nth 1 a)
X                (math-add (nth 2 a) b)
X                (math-add (nth 3 a) b)))))
X    ((and (eq (car-safe b) 'intv)
X          (or (Math-anglep a)
X          (eq (car a) 'date)
X          (not (Math-objvecp a))))
X     (math-make-intv (nth 1 b)
X             (math-add a (nth 2 b))
X             (math-add a (nth 3 b))))
X    ((eq (car-safe a) 'date)
X     (cond ((eq (car-safe b) 'date)
X        (math-add (nth 1 a) (nth 1 b)))
X           ((eq (car-safe b) 'hms)
X        (let ((parts (math-date-parts (nth 1 a))))
X          (list 'date
X            (math-add (car parts)   ; this minimizes roundoff
X                  (math-div (math-add
X                         (math-add (nth 1 parts)
X                               (nth 2 parts))
X                         (math-add
X                          (math-mul (nth 1 b) 3600)
X                          (math-add (math-mul (nth 2 b) 60)
X                            (nth 3 b))))
X                        86400)))))
X           ((Math-realp b)
X        (list 'date (math-add (nth 1 a) b)))
X           (t nil)))
X    ((eq (car-safe b) 'date)
X     (math-add-objects-fancy b a))
X    ((and (eq (car-safe a) 'mod)
X          (eq (car-safe b) 'mod)
X          (equal (nth 2 a) (nth 2 b)))
X     (math-make-mod (math-add (nth 1 a) (nth 1 b)) (nth 2 a)))
X    ((and (eq (car-safe a) 'mod)
X          (Math-anglep b))
X     (math-make-mod (math-add (nth 1 a) b) (nth 2 a)))
X    ((and (eq (car-safe b) 'mod)
X          (Math-anglep a))
X     (math-make-mod (math-add a (nth 1 b)) (nth 2 b)))
X    ((and (or (eq (car-safe a) 'hms) (eq (car-safe b) 'hms))
X          (and (Math-anglep a) (Math-anglep b)))
X     (or (eq (car-safe a) 'hms) (setq a (math-to-hms a)))
X     (or (eq (car-safe b) 'hms) (setq b (math-to-hms b)))
X     (math-normalize
X      (if (math-negp a)
X          (math-neg (math-add (math-neg a) (math-neg b)))
X        (if (math-negp b)
X        (let* ((s (math-add (nth 3 a) (nth 3 b)))
X               (m (math-add (nth 2 a) (nth 2 b)))
X               (h (math-add (nth 1 a) (nth 1 b))))
X          (if (math-negp s)
X              (setq s (math-add s 60)
X                m (math-add m -1)))
X          (if (math-negp m)
X              (setq m (math-add m 60)
X                h (math-add h -1)))
X          (if (math-negp h)
X              (math-add b a)
X            (list 'hms h m s)))
X          (let* ((s (math-add (nth 3 a) (nth 3 b)))
X             (m (math-add (nth 2 a) (nth 2 b)))
X             (h (math-add (nth 1 a) (nth 1 b))))
X        (list 'hms h m s))))))
X    (t (calc-record-why "*Incompatible arguments for +" a b)))
)
X
(defun math-add-symb-fancy (a b)
X  (or (and math-simplify-only
X       (not (equal a math-simplify-only))
X       (list '+ a b))
X      (and (eq (car-safe b) '+)
X       (math-add (math-add a (nth 1 b))
X             (nth 2 b)))
X      (and (eq (car-safe b) '-)
X       (math-sub (math-add a (nth 1 b))
X             (nth 2 b)))
X      (and (eq (car-safe b) 'neg)
X       (eq (car-safe (nth 1 b)) '+)
X       (math-sub (math-sub a (nth 1 (nth 1 b)))
X             (nth 2 (nth 1 b))))
X      (and (or (and (Math-vectorp a) (math-known-scalarp b))
X           (and (Math-vectorp b) (math-known-scalarp a)))
X       (math-map-vec-2 'math-add a b))
X      (let ((inf (math-infinitep a)))
X    (cond
X     (inf
X      (let ((inf2 (math-infinitep b)))
X        (if inf2
X        (if (or (memq (nth 2 inf) '(var-uinf var-nan))
X            (memq (nth 2 inf2) '(var-uinf var-nan)))
X            '(var nan var-nan)
X          (let ((dir (math-infinite-dir a inf))
X            (dir2 (math-infinite-dir b inf2)))
X            (if (and (Math-objectp dir) (Math-objectp dir2))
X            (if (Math-equal dir dir2)
X                a
X              '(var nan var-nan)))))
X          (if (and (equal a '(var inf var-inf))
X               (eq (car-safe b) 'intv)
X               (memq (nth 1 b) '(2 3))
X               (equal (nth 2 b) '(neg (var inf var-inf))))
X          (list 'intv 3 (nth 2 b) a)
X        (if (and (equal a '(neg (var inf var-inf)))
X             (eq (car-safe b) 'intv)
X             (memq (nth 1 b) '(1 3))
X             (equal (nth 3 b) '(var inf var-inf)))
X            (list 'intv 3 a (nth 3 b))
X          a)))))
X     ((math-infinitep b)
X      (if (eq (car-safe a) 'intv)
X          (math-add b a)
X        b))
X     ((eq (car-safe a) '+)
X      (let ((temp (math-combine-sum (nth 2 a) b nil nil t)))
X        (and temp
X         (math-add (nth 1 a) temp))))
X     ((eq (car-safe a) '-)
X      (let ((temp (math-combine-sum (nth 2 a) b t nil t)))
X        (and temp
X         (math-add (nth 1 a) temp))))
X     ((and (Math-objectp a) (Math-objectp b))
X      nil)
X     (t
X      (math-combine-sum a b nil nil nil))))
X      (and (Math-looks-negp b)
X       (list '- a (math-neg b)))
X      (and (Math-looks-negp a)
X       (list '- b (math-neg a)))
X      (and (eq (car-safe a) 'calcFunc-idn)
X       (= (length a) 2)
X       (or (and (eq (car-safe b) 'calcFunc-idn)
X            (= (length b) 2)
X            (list 'calcFunc-idn (math-add (nth 1 a) (nth 1 b))))
X           (and (math-square-matrixp b)
X            (math-add (math-mimic-ident (nth 1 a) b) b))
X           (and (math-known-scalarp b)
X            (math-add (nth 1 a) b))))
X      (and (eq (car-safe b) 'calcFunc-idn)
X       (= (length a) 2)
X       (or (and (math-square-matrixp a)
X            (math-add a (math-mimic-ident (nth 1 b) a)))
X           (and (math-known-scalarp a)
X            (math-add a (nth 1 b)))))
X      (list '+ a b))
)
X
X
(defun calcFunc-mul (&rest rest)
X  (if rest
X      (let ((a (car rest)))
X    (while (setq rest (cdr rest))
X      (setq a (list '* a (car rest))))
X    (math-normalize a))
X    1)
)
X
(defun math-mul-objects-fancy (a b)
X  (cond ((and (Math-numberp a) (Math-numberp b))
X     (math-normalize
X      (if (math-want-polar a b)
X          (let ((a (math-polar a))
X            (b (math-polar b)))
X        (list 'polar
X              (math-mul (nth 1 a) (nth 1 b))
X              (math-fix-circular (math-add (nth 2 a) (nth 2 b)))))
X        (setq a (math-complex a)
X          b (math-complex b))
X        (list 'cplx
X          (math-sub (math-mul (nth 1 a) (nth 1 b))
X                (math-mul (nth 2 a) (nth 2 b)))
X          (math-add (math-mul (nth 1 a) (nth 2 b))
X                (math-mul (nth 2 a) (nth 1 b)))))))
X    ((Math-vectorp a)
X     (if (Math-vectorp b)
X         (if (math-matrixp a)
X         (if (math-matrixp b)
X             (if (= (length (nth 1 a)) (length b))
X             (math-mul-mats a b)
X               (math-dimension-error))
X           (if (= (length (nth 1 a)) 2)
X               (if (= (length a) (length b))
X               (math-mul-mats a (list 'vec b))
X             (math-dimension-error))
X             (if (= (length (nth 1 a)) (length b))
X             (math-mul-mat-vec a b)
X               (math-dimension-error))))
X           (if (math-matrixp b)
X           (if (= (length a) (length b))
X               (nth 1 (math-mul-mats (list 'vec a) b))
X             (math-dimension-error))
X         (if (= (length a) (length b))
X             (math-dot-product a b)
X           (math-dimension-error))))
X       (math-map-vec-2 'math-mul a b)))
X    ((Math-vectorp b)
X     (math-map-vec-2 'math-mul a b))
X    ((eq (car-safe a) 'sdev)
X     (if (eq (car-safe b) 'sdev)
X         (math-make-sdev (math-mul (nth 1 a) (nth 1 b))
X                 (math-hypot (math-mul (nth 2 a) (nth 1 b))
X                     (math-mul (nth 2 b) (nth 1 a))))
X       (and (or (Math-scalarp b)
X            (not (Math-objvecp b)))
X        (math-make-sdev (math-mul (nth 1 a) b)
X                (math-mul (nth 2 a) b)))))
X    ((and (eq (car-safe b) 'sdev)
X          (or (Math-scalarp a)
X          (not (Math-objvecp a))))
X     (math-make-sdev (math-mul a (nth 1 b)) (math-mul a (nth 2 b))))
X    ((and (eq (car-safe a) 'intv) (Math-anglep b))
X     (if (Math-negp b)
X         (math-neg (math-mul a (math-neg b)))
X       (math-make-intv (nth 1 a)
X               (math-mul (nth 2 a) b)
X               (math-mul (nth 3 a) b))))
X    ((and (eq (car-safe b) 'intv) (Math-anglep a))
X     (math-mul b a))
X    ((and (eq (car-safe a) 'intv) (math-intv-constp a)
X          (eq (car-safe b) 'intv) (math-intv-constp b))
X     (let ((lo (math-mul a (nth 2 b)))
X           (hi (math-mul a (nth 3 b))))
X       (or (eq (car-safe lo) 'intv)
X           (setq lo (list 'intv (if (memq (nth 1 b) '(2 3)) 3 0) lo lo)))
X       (or (eq (car-safe hi) 'intv)
X           (setq hi (list 'intv (if (memq (nth 1 b) '(1 3)) 3 0) hi hi)))
X       (math-combine-intervals
X        (nth 2 lo) (and (or (memq (nth 1 b) '(2 3))
X                (math-infinitep (nth 2 lo)))
X                (memq (nth 1 lo) '(2 3)))
X        (nth 3 lo) (and (or (memq (nth 1 b) '(2 3))
X                (math-infinitep (nth 3 lo)))
X                (memq (nth 1 lo) '(1 3)))
X        (nth 2 hi) (and (or (memq (nth 1 b) '(1 3))
X                (math-infinitep (nth 2 hi)))
X                (memq (nth 1 hi) '(2 3)))
X        (nth 3 hi) (and (or (memq (nth 1 b) '(1 3))
X                (math-infinitep (nth 3 hi)))
X                (memq (nth 1 hi) '(1 3))))))
X    ((and (eq (car-safe a) 'mod)
X          (eq (car-safe b) 'mod)
X          (equal (nth 2 a) (nth 2 b)))
X     (math-make-mod (math-mul (nth 1 a) (nth 1 b)) (nth 2 a)))
X    ((and (eq (car-safe a) 'mod)
X          (Math-anglep b))
X     (math-make-mod (math-mul (nth 1 a) b) (nth 2 a)))
X    ((and (eq (car-safe b) 'mod)
X          (Math-anglep a))
X     (math-make-mod (math-mul a (nth 1 b)) (nth 2 b)))
X    ((and (eq (car-safe a) 'hms) (Math-realp b))
X     (math-with-extra-prec 2
X       (math-to-hms (math-mul (math-from-hms a 'deg) b) 'deg)))
X    ((and (eq (car-safe b) 'hms) (Math-realp a))
X     (math-mul b a))
X    (t (calc-record-why "*Incompatible arguments for *" a b)))
SHAR_EOF
true || echo 'restore of calc-arith.el failed'
fi
echo 'End of  part 8'
echo 'File calc-arith.el is continued in part 9'
echo 9 > _shar_seq_.tmp
exit 0
exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].