Newsgroups: comp.sources.misc
From: daveg@synaptics.com (David Gillespie)
Subject:  v24i056:  gnucalc - GNU Emacs Calculator, v2.00, Part08/56
Message-ID: <1991Oct29.225927.19993@sparky.imd.sterling.com>
X-Md4-Signature: da4707b63937149a0325ffa6456ffa96
Date: Tue, 29 Oct 1991 22:59:27 GMT
Approved: kent@sparky.imd.sterling.com

Submitted-by: daveg@synaptics.com (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, daveg@csvax.cs.caltech.edu.
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: kent@sparky.IMD.Sterling.COM
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    (402) 291-8300         FAX:      (402) 291-4362
Please send comp.sources.misc-related mail to kent@uunet.uu.net.