code.delx.au - gnu-emacs/blob - lisp/calc/calc-arith.el

   1 ;;; calc-arith.el --- arithmetic functions for Calc
   2
   3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
   4
   5 ;; Author: David Gillespie <daveg@synaptics.com>
   6 ;; Maintainer: Colin Walters <walters@debian.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY.  No author or distributor
  12 ;; accepts responsibility to anyone for the consequences of using it
  13 ;; or for whether it serves any particular purpose or works at all,
  14 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  15 ;; License for full details.
  16
  17 ;; Everyone is granted permission to copy, modify and redistribute
  18 ;; GNU Emacs, but only under the conditions described in the
  19 ;; GNU Emacs General Public License.   A copy of this license is
  20 ;; supposed to have been given to you along with GNU Emacs so you
  21 ;; can know your rights and responsibilities.  It should be in a
  22 ;; file named COPYING.  Among other things, the copyright notice
  23 ;; and this notice must be preserved on all copies.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 ;; This file is autoloaded from calc-ext.el.
  30 (require 'calc-ext)
  31
  32 (require 'calc-macs)
  33
  34 (defun calc-Need-calc-arith () nil)
  35
  36
  37 ;;; Arithmetic.
  38
  39 (defun calc-min (arg)
  40   (interactive "P")
  41   (calc-slow-wrapper
  42    (calc-binary-op "min" 'calcFunc-min arg '(var inf var-inf))))
  43
  44 (defun calc-max (arg)
  45   (interactive "P")
  46   (calc-slow-wrapper
  47    (calc-binary-op "max" 'calcFunc-max arg '(neg (var inf var-inf)))))
  48
  49 (defun calc-abs (arg)
  50   (interactive "P")
  51   (calc-slow-wrapper
  52    (calc-unary-op "abs" 'calcFunc-abs arg)))
  53
  54
  55 (defun calc-idiv (arg)
  56   (interactive "P")
  57   (calc-slow-wrapper
  58    (calc-binary-op "\\" 'calcFunc-idiv arg 1)))
  59
  60
  61 (defun calc-floor (arg)
  62   (interactive "P")
  63   (calc-slow-wrapper
  64    (if (calc-is-inverse)
  65        (if (calc-is-hyperbolic)
  66            (calc-unary-op "ceil" 'calcFunc-fceil arg)
  67          (calc-unary-op "ceil" 'calcFunc-ceil arg))
  68      (if (calc-is-hyperbolic)
  69          (calc-unary-op "flor" 'calcFunc-ffloor arg)
  70        (calc-unary-op "flor" 'calcFunc-floor arg)))))
  71
  72 (defun calc-ceiling (arg)
  73   (interactive "P")
  74   (calc-invert-func)
  75   (calc-floor arg))
  76
  77 (defun calc-round (arg)
  78   (interactive "P")
  79   (calc-slow-wrapper
  80    (if (calc-is-inverse)
  81        (if (calc-is-hyperbolic)
  82            (calc-unary-op "trnc" 'calcFunc-ftrunc arg)
  83          (calc-unary-op "trnc" 'calcFunc-trunc arg))
  84      (if (calc-is-hyperbolic)
  85          (calc-unary-op "rond" 'calcFunc-fround arg)
  86        (calc-unary-op "rond" 'calcFunc-round arg)))))
  87
  88 (defun calc-trunc (arg)
  89   (interactive "P")
  90   (calc-invert-func)
  91   (calc-round arg))
  92
  93 (defun calc-mant-part (arg)
  94   (interactive "P")
  95   (calc-slow-wrapper
  96    (calc-unary-op "mant" 'calcFunc-mant arg)))
  97
  98 (defun calc-xpon-part (arg)
  99   (interactive "P")
 100   (calc-slow-wrapper
 101    (calc-unary-op "xpon" 'calcFunc-xpon arg)))
 102
 103 (defun calc-scale-float (arg)
 104   (interactive "P")
 105   (calc-slow-wrapper
 106    (calc-binary-op "scal" 'calcFunc-scf arg)))
 107
 108 (defun calc-abssqr (arg)
 109   (interactive "P")
 110   (calc-slow-wrapper
 111    (calc-unary-op "absq" 'calcFunc-abssqr arg)))
 112
 113 (defun calc-sign (arg)
 114   (interactive "P")
 115   (calc-slow-wrapper
 116    (calc-unary-op "sign" 'calcFunc-sign arg)))
 117
 118 (defun calc-increment (arg)
 119   (interactive "p")
 120   (calc-wrapper
 121    (calc-enter-result 1 "incr" (list 'calcFunc-incr (calc-top-n 1) arg))))
 122
 123 (defun calc-decrement (arg)
 124   (interactive "p")
 125   (calc-wrapper
 126    (calc-enter-result 1 "decr" (list 'calcFunc-decr (calc-top-n 1) arg))))
 127
 128
 129 (defun math-abs-approx (a)
 130   (cond ((Math-negp a)
 131          (math-neg a))
 132         ((Math-anglep a)
 133          a)
 134         ((eq (car a) 'cplx)
 135          (math-add (math-abs (nth 1 a)) (math-abs (nth 2 a))))
 136         ((eq (car a) 'polar)
 137          (nth 1 a))
 138         ((eq (car a) 'sdev)
 139          (math-abs-approx (nth 1 a)))
 140         ((eq (car a) 'intv)
 141          (math-max (math-abs (nth 2 a)) (math-abs (nth 3 a))))
 142         ((eq (car a) 'date)
 143          a)
 144         ((eq (car a) 'vec)
 145          (math-reduce-vec 'math-add-abs-approx a))
 146         ((eq (car a) 'calcFunc-abs)
 147          (car a))
 148         (t a)))
 149
 150 (defun math-add-abs-approx (a b)
 151   (math-add (math-abs-approx a) (math-abs-approx b)))
 152
 153
 154 ;;;; Declarations.
 155
 156 (defvar math-decls-cache-tag nil)
 157 (defvar math-decls-cache nil)
 158 (defvar math-decls-all nil)
 159
 160 ;;; Math-decls-cache is an a-list where each entry is a list of the form:
 161 ;;;   (VAR TYPES RANGE)
 162 ;;; where VAR is a variable name (with var- prefix) or function name;
 163 ;;;       TYPES is a list of type symbols (any, int, frac, ...)
 164 ;;;       RANGE is a sorted vector of intervals describing the range.
 165
 166 (defun math-setup-declarations ()
 167   (or (eq math-decls-cache-tag (calc-var-value 'var-Decls))
 168       (let ((p (calc-var-value 'var-Decls))
 169             vec type range)
 170         (setq math-decls-cache-tag p
 171               math-decls-cache nil)
 172         (and (eq (car-safe p) 'vec)
 173              (while (setq p (cdr p))
 174                (and (eq (car-safe (car p)) 'vec)
 175                     (setq vec (nth 2 (car p)))
 176                     (condition-case err
 177                         (let ((v (nth 1 (car p))))
 178                           (setq type nil range nil)
 179                           (or (eq (car-safe vec) 'vec)
 180                               (setq vec (list 'vec vec)))
 181                           (while (and (setq vec (cdr vec))
 182                                       (not (Math-objectp (car vec))))
 183                             (and (eq (car-safe (car vec)) 'var)
 184                                  (let ((st (assq (nth 1 (car vec))
 185                                                  math-super-types)))
 186                                    (cond (st (setq type (append type st)))
 187                                          ((eq (nth 1 (car vec)) 'pos)
 188                                           (setq type (append type
 189                                                              '(real number))
 190                                                 range
 191                                                 '(intv 1 0 (var inf var-inf))))
 192                                          ((eq (nth 1 (car vec)) 'nonneg)
 193                                           (setq type (append type
 194                                                              '(real number))
 195                                                 range
 196                                                 '(intv 3 0
 197                                                        (var inf var-inf))))))))
 198                           (if vec
 199                               (setq type (append type '(real number))
 200                                     range (math-prepare-set (cons 'vec vec))))
 201                           (setq type (list type range))
 202                           (or (eq (car-safe v) 'vec)
 203                               (setq v (list 'vec v)))
 204                           (while (setq v (cdr v))
 205                             (if (or (eq (car-safe (car v)) 'var)
 206                                     (not (Math-primp (car v))))
 207                                 (setq math-decls-cache
 208                                       (cons (cons (if (eq (car (car v)) 'var)
 209                                                       (nth 2 (car v))
 210                                                     (car (car v)))
 211                                                   type)
 212                                             math-decls-cache)))))
 213                       (error nil)))))
 214         (setq math-decls-all (assq 'var-All math-decls-cache)))))
 215
 216 (defvar math-super-types
 217   '((int numint rat real number)
 218     (numint real number)
 219     (frac rat real number)
 220     (rat real number)
 221     (float real number)
 222     (real number)
 223     (number)
 224     (scalar)
 225     (matrix vector)
 226     (vector)
 227     (const)))
 228
 229 (defun math-known-scalarp (a &optional assume-scalar)
 230   (math-setup-declarations)
 231   (if (if calc-matrix-mode
 232           (eq calc-matrix-mode 'scalar)
 233         assume-scalar)
 234       (not (math-check-known-matrixp a))
 235     (math-check-known-scalarp a)))
 236
 237 (defun math-known-matrixp (a)
 238   (and (not (Math-scalarp a))
 239        (not (math-known-scalarp a t))))
 240
 241 ;;; Try to prove that A is a scalar (i.e., a non-vector).
 242 (defun math-check-known-scalarp (a)
 243   (cond ((Math-objectp a) t)
 244         ((memq (car a) math-scalar-functions)
 245          t)
 246         ((memq (car a) math-real-scalar-functions)
 247          t)
 248         ((memq (car a) math-scalar-if-args-functions)
 249          (while (and (setq a (cdr a))
 250                      (math-check-known-scalarp (car a))))
 251          (null a))
 252         ((eq (car a) '^)
 253          (math-check-known-scalarp (nth 1 a)))
 254         ((math-const-var a) t)
 255         (t
 256          (let ((decl (if (eq (car a) 'var)
 257                          (or (assq (nth 2 a) math-decls-cache)
 258                              math-decls-all)
 259                        (assq (car a) math-decls-cache))))
 260            (memq 'scalar (nth 1 decl))))))
 261
 262 ;;; Try to prove that A is *not* a scalar.
 263 (defun math-check-known-matrixp (a)
 264   (cond ((Math-objectp a) nil)
 265         ((memq (car a) math-nonscalar-functions)
 266          t)
 267         ((memq (car a) math-scalar-if-args-functions)
 268          (while (and (setq a (cdr a))
 269                      (not (math-check-known-matrixp (car a)))))
 270          a)
 271         ((eq (car a) '^)
 272          (math-check-known-matrixp (nth 1 a)))
 273         ((math-const-var a) nil)
 274         (t
 275          (let ((decl (if (eq (car a) 'var)
 276                          (or (assq (nth 2 a) math-decls-cache)
 277                              math-decls-all)
 278                        (assq (car a) math-decls-cache))))
 279            (memq 'vector (nth 1 decl))))))
 280
 281
 282 ;;; Try to prove that A is a real (i.e., not complex).
 283 (defun math-known-realp (a)
 284   (< (math-possible-signs a) 8))
 285
 286 ;;; Try to prove that A is real and positive.
 287 (defun math-known-posp (a)
 288   (eq (math-possible-signs a) 4))
 289
 290 ;;; Try to prove that A is real and negative.
 291 (defun math-known-negp (a)
 292   (eq (math-possible-signs a) 1))
 293
 294 ;;; Try to prove that A is real and nonnegative.
 295 (defun math-known-nonnegp (a)
 296   (memq (math-possible-signs a) '(2 4 6)))
 297
 298 ;;; Try to prove that A is real and nonpositive.
 299 (defun math-known-nonposp (a)
 300   (memq (math-possible-signs a) '(1 2 3)))
 301
 302 ;;; Try to prove that A is nonzero.
 303 (defun math-known-nonzerop (a)
 304   (memq (math-possible-signs a) '(1 4 5 8 9 12 13)))
 305
 306 ;;; Return true if A is negative, or looks negative but we don't know.
 307 (defun math-guess-if-neg (a)
 308   (let ((sgn (math-possible-signs a)))
 309     (if (memq sgn '(1 3))
 310         t
 311       (if (memq sgn '(2 4 6))
 312           nil
 313         (math-looks-negp a)))))
 314
 315 ;;; Find the possible signs of A, assuming A is a number of some kind.
 316 ;;; Returns an integer with bits:  1  may be negative,
 317 ;;;                                2  may be zero,
 318 ;;;                                4  may be positive,
 319 ;;;                                8  may be nonreal.
 320
 321 (defun math-possible-signs (a &optional origin)
 322   (cond ((Math-objectp a)
 323          (if origin (setq a (math-sub a origin)))
 324          (cond ((Math-posp a) 4)
 325                ((Math-negp a) 1)
 326                ((Math-zerop a) 2)
 327                ((eq (car a) 'intv)
 328                 (cond ((Math-zerop (nth 2 a)) 6)
 329                       ((Math-zerop (nth 3 a)) 3)
 330                       (t 7)))
 331                ((eq (car a) 'sdev)
 332                 (if (math-known-realp (nth 1 a)) 7 15))
 333                (t 8)))
 334         ((memq (car a) '(+ -))
 335          (cond ((Math-realp (nth 1 a))
 336                 (if (eq (car a) '-)
 337                     (math-neg-signs
 338                      (math-possible-signs (nth 2 a)
 339                                           (if origin
 340                                               (math-add origin (nth 1 a))
 341                                             (nth 1 a))))
 342                   (math-possible-signs (nth 2 a)
 343                                        (if origin
 344                                            (math-sub origin (nth 1 a))
 345                                          (math-neg (nth 1 a))))))
 346                ((Math-realp (nth 2 a))
 347                 (let ((org (if (eq (car a) '-)
 348                                (nth 2 a)
 349                              (math-neg (nth 2 a)))))
 350                   (math-possible-signs (nth 1 a)
 351                                        (if origin
 352                                            (math-add origin org)
 353                                          org))))
 354                (t
 355                 (let ((s1 (math-possible-signs (nth 1 a) origin))
 356                       (s2 (math-possible-signs (nth 2 a))))
 357                   (if (eq (car a) '-) (setq s2 (math-neg-signs s2)))
 358                   (cond ((eq s1 s2) s1)
 359                         ((eq s1 2) s2)
 360                         ((eq s2 2) s1)
 361                         ((>= s1 8) 15)
 362                         ((>= s2 8) 15)
 363                         ((and (eq s1 4) (eq s2 6)) 4)
 364                         ((and (eq s2 4) (eq s1 6)) 4)
 365                         ((and (eq s1 1) (eq s2 3)) 1)
 366                         ((and (eq s2 1) (eq s1 3)) 1)
 367                         (t 7))))))
 368         ((eq (car a) 'neg)
 369          (math-neg-signs (math-possible-signs
 370                           (nth 1 a)
 371                           (and origin (math-neg origin)))))
 372         ((and origin (Math-zerop origin) (setq origin nil)
 373               nil))
 374         ((and (or (eq (car a) '*)
 375                   (and (eq (car a) '/) origin))
 376               (Math-realp (nth 1 a)))
 377          (let ((s (if (eq (car a) '*)
 378                       (if (Math-zerop (nth 1 a))
 379                           (math-possible-signs 0 origin)
 380                         (math-possible-signs (nth 2 a)
 381                                              (math-div (or origin 0)
 382                                                        (nth 1 a))))
 383                     (math-neg-signs
 384                      (math-possible-signs (nth 2 a)
 385                                           (math-div (nth 1 a)
 386                                                     origin))))))
 387            (if (Math-negp (nth 1 a)) (math-neg-signs s) s)))
 388         ((and (memq (car a) '(* /)) (Math-realp (nth 2 a)))
 389          (let ((s (math-possible-signs (nth 1 a)
 390                                        (if (eq (car a) '*)
 391                                            (math-mul (or origin 0) (nth 2 a))
 392                                          (math-div (or origin 0) (nth 2 a))))))
 393            (if (Math-negp (nth 2 a)) (math-neg-signs s) s)))
 394         ((eq (car a) 'vec)
 395          (let ((signs 0))
 396            (while (and (setq a (cdr a)) (< signs 15))
 397              (setq signs (logior signs (math-possible-signs
 398                                         (car a) origin))))
 399            signs))
 400         (t (let ((sign
 401                   (cond
 402                    ((memq (car a) '(* /))
 403                     (let ((s1 (math-possible-signs (nth 1 a)))
 404                           (s2 (math-possible-signs (nth 2 a))))
 405                       (cond ((>= s1 8) 15)
 406                             ((>= s2 8) 15)
 407                             ((and (eq (car a) '/) (memq s2 '(2 3 6 7))) 15)
 408                             (t
 409                              (logior (if (memq s1 '(4 5 6 7)) s2 0)
 410                                      (if (memq s1 '(2 3 6 7)) 2 0)
 411                                      (if (memq s1 '(1 3 5 7))
 412                                          (math-neg-signs s2) 0))))))
 413                    ((eq (car a) '^)
 414                     (let ((s1 (math-possible-signs (nth 1 a)))
 415                           (s2 (math-possible-signs (nth 2 a))))
 416                       (cond ((>= s1 8) 15)
 417                             ((>= s2 8) 15)
 418                             ((eq s1 4) 4)
 419                             ((eq s1 2) (if (eq s2 4) 2 15))
 420                             ((eq s2 2) (if (memq s1 '(1 5)) 2 15))
 421                             ((Math-integerp (nth 2 a))
 422                              (if (math-evenp (nth 2 a))
 423                                  (if (memq s1 '(3 6 7)) 6 4)
 424                                s1))
 425                             ((eq s1 6) (if (eq s2 4) 6 15))
 426                             (t 7))))
 427                    ((eq (car a) '%)
 428                     (let ((s2 (math-possible-signs (nth 2 a))))
 429                       (cond ((>= s2 8) 7)
 430                             ((eq s2 2) 2)
 431                             ((memq s2 '(4 6)) 6)
 432                             ((memq s2 '(1 3)) 3)
 433                             (t 7))))
 434                    ((and (memq (car a) '(calcFunc-abs calcFunc-abssqr))
 435                          (= (length a) 2))
 436                     (let ((s1 (math-possible-signs (nth 1 a))))
 437                       (cond ((eq s1 2) 2)
 438                             ((memq s1 '(1 4 5)) 4)
 439                             (t 6))))
 440                    ((and (eq (car a) 'calcFunc-exp) (= (length a) 2))
 441                     (let ((s1 (math-possible-signs (nth 1 a))))
 442                       (if (>= s1 8)
 443                           15
 444                         (if (or (not origin) (math-negp origin))
 445                             4
 446                           (setq origin (math-sub (or origin 0) 1))
 447                           (if (Math-zerop origin) (setq origin nil))
 448                           s1))))
 449                    ((or (and (memq (car a) '(calcFunc-ln calcFunc-log10))
 450                              (= (length a) 2))
 451                         (and (eq (car a) 'calcFunc-log)
 452                              (= (length a) 3)
 453                              (math-known-posp (nth 2 a))))
 454                     (if (math-known-nonnegp (nth 1 a))
 455                         (math-possible-signs (nth 1 a) 1)
 456                       15))
 457                    ((and (eq (car a) 'calcFunc-sqrt) (= (length a) 2))
 458                     (let ((s1 (math-possible-signs (nth 1 a))))
 459                       (if (memq s1 '(2 4 6)) s1 15)))
 460                    ((memq (car a) math-nonnegative-functions) 6)
 461                    ((memq (car a) math-positive-functions) 4)
 462                    ((memq (car a) math-real-functions) 7)
 463                    ((memq (car a) math-real-scalar-functions) 7)
 464                    ((and (memq (car a) math-real-if-arg-functions)
 465                          (= (length a) 2))
 466                     (if (math-known-realp (nth 1 a)) 7 15)))))
 467              (cond (sign
 468                     (if origin
 469                         (+ (logand sign 8)
 470                            (if (Math-posp origin)
 471                                (if (memq sign '(1 2 3 8 9 10 11)) 1 7)
 472                              (if (memq sign '(2 4 6 8 10 12 14)) 4 7)))
 473                       sign))
 474                    ((math-const-var a)
 475                     (cond ((eq (nth 2 a) 'var-pi)
 476                            (if origin
 477                                (math-possible-signs (math-pi) origin)
 478                              4))
 479                           ((eq (nth 2 a) 'var-e)
 480                            (if origin
 481                                (math-possible-signs (math-e) origin)
 482                              4))
 483                           ((eq (nth 2 a) 'var-inf) 4)
 484                           ((eq (nth 2 a) 'var-uinf) 13)
 485                           ((eq (nth 2 a) 'var-i) 8)
 486                           (t 15)))
 487                    (t
 488                     (math-setup-declarations)
 489                     (let ((decl (if (eq (car a) 'var)
 490                                     (or (assq (nth 2 a) math-decls-cache)
 491                                         math-decls-all)
 492                                   (assq (car a) math-decls-cache))))
 493                       (if (and origin
 494                                (memq 'int (nth 1 decl))
 495                                (not (Math-num-integerp origin)))
 496                           5
 497                         (if (nth 2 decl)
 498                             (math-possible-signs (nth 2 decl) origin)
 499                           (if (memq 'real (nth 1 decl))
 500                               7
 501                             15))))))))))
 502
 503 (defun math-neg-signs (s1)
 504   (if (>= s1 8)
 505       (+ 8 (math-neg-signs (- s1 8)))
 506     (+ (if (memq s1 '(1 3 5 7)) 4 0)
 507        (if (memq s1 '(2 3 6 7)) 2 0)
 508        (if (memq s1 '(4 5 6 7)) 1 0))))
 509
 510
 511 ;;; Try to prove that A is an integer.
 512 (defun math-known-integerp (a)
 513   (eq (math-possible-types a) 1))
 514
 515 (defun math-known-num-integerp (a)
 516   (<= (math-possible-types a t) 3))
 517
 518 (defun math-known-imagp (a)
 519   (= (math-possible-types a) 16))
 520
 521
 522 ;;; Find the possible types of A.
 523 ;;; Returns an integer with bits:  1  may be integer.
 524 ;;;                                2  may be integer-valued float.
 525 ;;;                                4  may be fraction.
 526 ;;;                                8  may be non-integer-valued float.
 527 ;;;                               16  may be imaginary.
 528 ;;;                               32  may be non-real, non-imaginary.
 529 ;;; Real infinities count as integers for the purposes of this function.
 530 (defun math-possible-types (a &optional num)
 531   (cond ((Math-objectp a)
 532          (cond ((Math-integerp a) (if num 3 1))
 533                ((Math-messy-integerp a) (if num 3 2))
 534                ((eq (car a) 'frac) (if num 12 4))
 535                ((eq (car a) 'float) (if num 12 8))
 536                ((eq (car a) 'intv)
 537                 (if (equal (nth 2 a) (nth 3 a))
 538                     (math-possible-types (nth 2 a))
 539                   15))
 540                ((eq (car a) 'sdev)
 541                 (if (math-known-realp (nth 1 a)) 15 63))
 542                ((eq (car a) 'cplx)
 543                 (if (math-zerop (nth 1 a)) 16 32))
 544                ((eq (car a) 'polar)
 545                 (if (or (Math-equal (nth 2 a) (math-quarter-circle nil))
 546                         (Math-equal (nth 2 a)
 547                                     (math-neg (math-quarter-circle nil))))
 548                     16 48))
 549                (t 63)))
 550         ((eq (car a) '/)
 551          (let* ((t1 (math-possible-types (nth 1 a) num))
 552                 (t2 (math-possible-types (nth 2 a) num))
 553                 (t12 (logior t1 t2)))
 554            (if (< t12 16)
 555                (if (> (logand t12 10) 0)
 556                    10
 557                  (if (or (= t1 4) (= t2 4) calc-prefer-frac)
 558                      5
 559                    15))
 560              (if (< t12 32)
 561                  (if (= t1 16)
 562                      (if (= t2 16) 15
 563                        (if (< t2 16) 16 31))
 564                    (if (= t2 16)
 565                        (if (< t1 16) 16 31)
 566                      31))
 567                63))))
 568         ((memq (car a) '(+ - * %))
 569          (let* ((t1 (math-possible-types (nth 1 a) num))
 570                 (t2 (math-possible-types (nth 2 a) num))
 571                 (t12 (logior t1 t2)))
 572            (if (eq (car a) '%)
 573                (setq t1 (logand t1 15) t2 (logand t2 15) t12 (logand t12 15)))
 574            (if (< t12 16)
 575                (let ((mask (if (<= t12 3)
 576                                1
 577                              (if (and (or (and (<= t1 3) (= (logand t2 3) 0))
 578                                           (and (<= t2 3) (= (logand t1 3) 0)))
 579                                       (memq (car a) '(+ -)))
 580                                  4
 581                                5))))
 582                  (if num
 583                      (* mask 3)
 584                    (logior (if (and (> (logand t1 5) 0) (> (logand t2 5) 0))
 585                                mask 0)
 586                            (if (> (logand t12 10) 0)
 587                                (* mask 2) 0))))
 588              (if (< t12 32)
 589                  (if (eq (car a) '*)
 590                      (if (= t1 16)
 591                          (if (= t2 16) 15
 592                            (if (< t2 16) 16 31))
 593                        (if (= t2 16)
 594                            (if (< t1 16) 16 31)
 595                          31))
 596                    (if (= t12 16) 16
 597                      (if (or (and (= t1 16) (< t2 16))
 598                              (and (= t2 16) (< t1 16))) 32 63)))
 599                63))))
 600         ((eq (car a) 'neg)
 601          (math-possible-types (nth 1 a)))
 602         ((eq (car a) '^)
 603          (let* ((t1 (math-possible-types (nth 1 a) num))
 604                 (t2 (math-possible-types (nth 2 a) num))
 605                 (t12 (logior t1 t2)))
 606            (if (and (<= t2 3) (math-known-nonnegp (nth 2 a)) (< t1 16))
 607                (let ((mask (logior (if (> (logand t1 3) 0) 1 0)
 608                                    (logand t1 4)
 609                                    (if (> (logand t1 12) 0) 5 0))))
 610                  (if num
 611                      (* mask 3)
 612                    (logior (if (and (> (logand t1 5) 0) (> (logand t2 5) 0))
 613                                mask 0)
 614                            (if (> (logand t12 10) 0)
 615                                (* mask 2) 0))))
 616              (if (and (math-known-nonnegp (nth 1 a))
 617                       (math-known-posp (nth 2 a)))
 618                  15
 619                63))))
 620         ((eq (car a) 'calcFunc-sqrt)
 621          (let ((t1 (math-possible-signs (nth 1 a))))
 622            (logior (if (> (logand t1 2) 0) 3 0)
 623                    (if (> (logand t1 1) 0) 16 0)
 624                    (if (> (logand t1 4) 0) 15 0)
 625                    (if (> (logand t1 8) 0) 32 0))))
 626         ((eq (car a) 'vec)
 627          (let ((types 0))
 628            (while (and (setq a (cdr a)) (< types 63))
 629              (setq types (logior types (math-possible-types (car a) t))))
 630            types))
 631         ((or (memq (car a) math-integer-functions)
 632              (and (memq (car a) math-rounding-functions)
 633                   (math-known-nonnegp (or (nth 2 a) 0))))
 634          1)
 635         ((or (memq (car a) math-num-integer-functions)
 636              (and (memq (car a) math-float-rounding-functions)
 637                   (math-known-nonnegp (or (nth 2 a) 0))))
 638          2)
 639         ((eq (car a) 'calcFunc-frac)
 640          5)
 641         ((and (eq (car a) 'calcFunc-float) (= (length a) 2))
 642          (let ((t1 (math-possible-types (nth 1 a))))
 643            (logior (if (> (logand t1 3) 0) 2 0)
 644                    (if (> (logand t1 12) 0) 8 0)
 645                    (logand t1 48))))
 646         ((and (memq (car a) '(calcFunc-abs calcFunc-abssqr))
 647               (= (length a) 2))
 648          (let ((t1 (math-possible-types (nth 1 a))))
 649            (if (>= t1 16)
 650                15
 651              t1)))
 652         ((math-const-var a)
 653          (cond ((memq (nth 2 a) '(var-e var-pi var-phi var-gamma)) 8)
 654                ((eq (nth 2 a) 'var-inf) 1)
 655                ((eq (nth 2 a) 'var-i) 16)
 656                (t 63)))
 657         (t
 658          (math-setup-declarations)
 659          (let ((decl (if (eq (car a) 'var)
 660                          (or (assq (nth 2 a) math-decls-cache)
 661                              math-decls-all)
 662                        (assq (car a) math-decls-cache))))
 663            (cond ((memq 'int (nth 1 decl))
 664                   1)
 665                  ((memq 'numint (nth 1 decl))
 666                   3)
 667                  ((memq 'frac (nth 1 decl))
 668                   4)
 669                  ((memq 'rat (nth 1 decl))
 670                   5)
 671                  ((memq 'float (nth 1 decl))
 672                   10)
 673                  ((nth 2 decl)
 674                   (math-possible-types (nth 2 decl)))
 675                  ((memq 'real (nth 1 decl))
 676                   15)
 677                  (t 63))))))
 678
 679 (defun math-known-evenp (a)
 680   (cond ((Math-integerp a)
 681          (math-evenp a))
 682         ((Math-messy-integerp a)
 683          (or (> (nth 2 a) 0)
 684              (math-evenp (math-trunc a))))
 685         ((eq (car a) '*)
 686          (if (math-known-evenp (nth 1 a))
 687              (math-known-num-integerp (nth 2 a))
 688            (if (math-known-num-integerp (nth 1 a))
 689                (math-known-evenp (nth 2 a)))))
 690         ((memq (car a) '(+ -))
 691          (or (and (math-known-evenp (nth 1 a))
 692                   (math-known-evenp (nth 2 a)))
 693              (and (math-known-oddp (nth 1 a))
 694                   (math-known-oddp (nth 2 a)))))
 695         ((eq (car a) 'neg)
 696          (math-known-evenp (nth 1 a)))))
 697
 698 (defun math-known-oddp (a)
 699   (cond ((Math-integerp a)
 700          (math-oddp a))
 701         ((Math-messy-integerp a)
 702          (and (<= (nth 2 a) 0)
 703               (math-oddp (math-trunc a))))
 704         ((memq (car a) '(+ -))
 705          (or (and (math-known-evenp (nth 1 a))
 706                   (math-known-oddp (nth 2 a)))
 707              (and (math-known-oddp (nth 1 a))
 708                   (math-known-evenp (nth 2 a)))))
 709         ((eq (car a) 'neg)
 710          (math-known-oddp (nth 1 a)))))
 711
 712
 713 (defun calcFunc-dreal (expr)
 714   (let ((types (math-possible-types expr)))
 715     (if (< types 16) 1
 716       (if (= (logand types 15) 0) 0
 717         (math-reject-arg expr 'realp 'quiet)))))
 718
 719 (defun calcFunc-dimag (expr)
 720   (let ((types (math-possible-types expr)))
 721     (if (= types 16) 1
 722       (if (= (logand types 16) 0) 0
 723         (math-reject-arg expr "Expected an imaginary number")))))
 724
 725 (defun calcFunc-dpos (expr)
 726   (let ((signs (math-possible-signs expr)))
 727     (if (eq signs 4) 1
 728       (if (memq signs '(1 2 3)) 0
 729         (math-reject-arg expr 'posp 'quiet)))))
 730
 731 (defun calcFunc-dneg (expr)
 732   (let ((signs (math-possible-signs expr)))
 733     (if (eq signs 1) 1
 734       (if (memq signs '(2 4 6)) 0
 735         (math-reject-arg expr 'negp 'quiet)))))
 736
 737 (defun calcFunc-dnonneg (expr)
 738   (let ((signs (math-possible-signs expr)))
 739     (if (memq signs '(2 4 6)) 1
 740       (if (eq signs 1) 0
 741         (math-reject-arg expr 'posp 'quiet)))))
 742
 743 (defun calcFunc-dnonzero (expr)
 744   (let ((signs (math-possible-signs expr)))
 745     (if (memq signs '(1 4 5 8 9 12 13)) 1
 746       (if (eq signs 2) 0
 747         (math-reject-arg expr 'nonzerop 'quiet)))))
 748
 749 (defun calcFunc-dint (expr)
 750   (let ((types (math-possible-types expr)))
 751     (if (= types 1) 1
 752       (if (= (logand types 1) 0) 0
 753         (math-reject-arg expr 'integerp 'quiet)))))
 754
 755 (defun calcFunc-dnumint (expr)
 756   (let ((types (math-possible-types expr t)))
 757     (if (<= types 3) 1
 758       (if (= (logand types 3) 0) 0
 759         (math-reject-arg expr 'integerp 'quiet)))))
 760
 761 (defun calcFunc-dnatnum (expr)
 762   (let ((res (calcFunc-dint expr)))
 763     (if (eq res 1)
 764         (calcFunc-dnonneg expr)
 765       res)))
 766
 767 (defun calcFunc-deven (expr)
 768   (if (math-known-evenp expr)
 769       1
 770     (if (or (math-known-oddp expr)
 771             (= (logand (math-possible-types expr) 3) 0))
 772         0
 773       (math-reject-arg expr "Can't tell if expression is odd or even"))))
 774
 775 (defun calcFunc-dodd (expr)
 776   (if (math-known-oddp expr)
 777       1
 778     (if (or (math-known-evenp expr)
 779             (= (logand (math-possible-types expr) 3) 0))
 780         0
 781       (math-reject-arg expr "Can't tell if expression is odd or even"))))
 782
 783 (defun calcFunc-drat (expr)
 784   (let ((types (math-possible-types expr)))
 785     (if (memq types '(1 4 5)) 1
 786       (if (= (logand types 5) 0) 0
 787         (math-reject-arg expr "Rational number expected")))))
 788
 789 (defun calcFunc-drange (expr)
 790   (math-setup-declarations)
 791   (let (range)
 792     (if (Math-realp expr)
 793         (list 'vec expr)
 794       (if (eq (car-safe expr) 'intv)
 795           expr
 796         (if (eq (car-safe expr) 'var)
 797             (setq range (nth 2 (or (assq (nth 2 expr) math-decls-cache)
 798                                    math-decls-all)))
 799           (setq range (nth 2 (assq (car-safe expr) math-decls-cache))))
 800         (if range
 801             (math-clean-set (copy-sequence range))
 802           (setq range (math-possible-signs expr))
 803           (if (< range 8)
 804               (aref [(vec)
 805                      (intv 2 (neg (var inf var-inf)) 0)
 806                      (vec 0)
 807                      (intv 3 (neg (var inf var-inf)) 0)
 808                      (intv 1 0 (var inf var-inf))
 809                      (vec (intv 2 (neg (var inf var-inf)) 0)
 810                           (intv 1 0 (var inf var-inf)))
 811                      (intv 3 0 (var inf var-inf))
 812                      (intv 3 (neg (var inf var-inf)) (var inf var-inf))] range)
 813             (math-reject-arg expr 'realp 'quiet)))))))
 814
 815 (defun calcFunc-dscalar (a)
 816   (if (math-known-scalarp a) 1
 817     (if (math-known-matrixp a) 0
 818       (math-reject-arg a 'objectp 'quiet))))
 819
 820
 821 ;;; The following lists are not exhaustive.
 822 (defvar math-scalar-functions '(calcFunc-det
 823                                 calcFunc-cnorm calcFunc-rnorm
 824                                 calcFunc-vlen calcFunc-vcount
 825                                 calcFunc-vsum calcFunc-vprod
 826                                 calcFunc-vmin calcFunc-vmax))
 827
 828 (defvar math-nonscalar-functions '(vec calcFunc-idn calcFunc-diag
 829                                        calcFunc-cvec calcFunc-index
 830                                        calcFunc-trn
 831                                        | calcFunc-append
 832                                        calcFunc-cons calcFunc-rcons
 833                                        calcFunc-tail calcFunc-rhead))
 834
 835 (defvar math-scalar-if-args-functions '(+ - * / neg))
 836
 837 (defvar math-real-functions '(calcFunc-arg
 838                               calcFunc-re calcFunc-im
 839                               calcFunc-floor calcFunc-ceil
 840                               calcFunc-trunc calcFunc-round
 841                               calcFunc-rounde calcFunc-roundu
 842                               calcFunc-ffloor calcFunc-fceil
 843                               calcFunc-ftrunc calcFunc-fround
 844                               calcFunc-frounde calcFunc-froundu))
 845
 846 (defvar math-positive-functions '())
 847
 848 (defvar math-nonnegative-functions '(calcFunc-cnorm calcFunc-rnorm
 849                                      calcFunc-vlen calcFunc-vcount))
 850
 851 (defvar math-real-scalar-functions '(% calcFunc-idiv calcFunc-abs
 852                                        calcFunc-choose calcFunc-perm
 853                                        calcFunc-eq calcFunc-neq
 854                                        calcFunc-lt calcFunc-gt
 855                                        calcFunc-leq calcFunc-geq
 856                                        calcFunc-lnot
 857                                        calcFunc-max calcFunc-min))
 858
 859 (defvar math-real-if-arg-functions '(calcFunc-sin calcFunc-cos
 860                                      calcFunc-tan calcFunc-arctan
 861                                      calcFunc-sinh calcFunc-cosh
 862                                      calcFunc-tanh calcFunc-exp
 863                                      calcFunc-gamma calcFunc-fact))
 864
 865 (defvar math-integer-functions '(calcFunc-idiv
 866                                  calcFunc-isqrt calcFunc-ilog
 867                                  calcFunc-vlen calcFunc-vcount))
 868
 869 (defvar math-num-integer-functions '())
 870
 871 (defvar math-rounding-functions '(calcFunc-floor
 872                                   calcFunc-ceil
 873                                   calcFunc-round calcFunc-trunc
 874                                   calcFunc-rounde calcFunc-roundu))
 875
 876 (defvar math-float-rounding-functions '(calcFunc-ffloor
 877                                         calcFunc-fceil
 878                                         calcFunc-fround calcFunc-ftrunc
 879                                         calcFunc-frounde calcFunc-froundu))
 880
 881 (defvar math-integer-if-args-functions '(+ - * % neg calcFunc-abs
 882                                            calcFunc-min calcFunc-max
 883                                            calcFunc-choose calcFunc-perm))
 884
 885
 886 ;;;; Arithmetic.
 887
 888 (defsubst calcFunc-neg (a)
 889   (math-normalize (list 'neg a)))
 890
 891 (defun math-neg-fancy (a)
 892   (cond ((eq (car a) 'polar)
 893          (list 'polar
 894                (nth 1 a)
 895                (if (math-posp (nth 2 a))
 896                    (math-sub (nth 2 a) (math-half-circle nil))
 897                  (math-add (nth 2 a) (math-half-circle nil)))))
 898         ((eq (car a) 'mod)
 899          (if (math-zerop (nth 1 a))
 900              a
 901            (list 'mod (math-sub (nth 2 a) (nth 1 a)) (nth 2 a))))
 902         ((eq (car a) 'sdev)
 903          (list 'sdev (math-neg (nth 1 a)) (nth 2 a)))
 904         ((eq (car a) 'intv)
 905          (math-make-intv (aref [0 2 1 3] (nth 1 a))
 906                          (math-neg (nth 3 a))
 907                          (math-neg (nth 2 a))))
 908         ((and math-simplify-only
 909               (not (equal a math-simplify-only)))
 910          (list 'neg a))
 911         ((eq (car a) '+)
 912          (math-sub (math-neg (nth 1 a)) (nth 2 a)))
 913         ((eq (car a) '-)
 914          (math-sub (nth 2 a) (nth 1 a)))
 915         ((and (memq (car a) '(* /))
 916               (math-okay-neg (nth 1 a)))
 917          (list (car a) (math-neg (nth 1 a)) (nth 2 a)))
 918         ((and (memq (car a) '(* /))
 919               (math-okay-neg (nth 2 a)))
 920          (list (car a) (nth 1 a) (math-neg (nth 2 a))))
 921         ((and (memq (car a) '(* /))
 922               (or (math-objectp (nth 1 a))
 923                   (and (eq (car (nth 1 a)) '*)
 924                        (math-objectp (nth 1 (nth 1 a))))))
 925          (list (car a) (math-neg (nth 1 a)) (nth 2 a)))
 926         ((and (eq (car a) '/)
 927               (or (math-objectp (nth 2 a))
 928                   (and (eq (car (nth 2 a)) '*)
 929                        (math-objectp (nth 1 (nth 2 a))))))
 930          (list (car a) (nth 1 a) (math-neg (nth 2 a))))
 931         ((and (eq (car a) 'var) (memq (nth 2 a) '(var-uinf var-nan)))
 932          a)
 933         ((eq (car a) 'neg)
 934          (nth 1 a))
 935         (t (list 'neg a))))
 936
 937 (defun math-okay-neg (a)
 938   (or (math-looks-negp a)
 939       (eq (car-safe a) '-)))
 940
 941 (defun math-neg-float (a)
 942   (list 'float (Math-integer-neg (nth 1 a)) (nth 2 a)))
 943
 944
 945 (defun calcFunc-add (&rest rest)
 946   (if rest
 947       (let ((a (car rest)))
 948         (while (setq rest (cdr rest))
 949           (setq a (list '+ a (car rest))))
 950         (math-normalize a))
 951     0))
 952
 953 (defun calcFunc-sub (&rest rest)
 954   (if rest
 955       (let ((a (car rest)))
 956         (while (setq rest (cdr rest))
 957           (setq a (list '- a (car rest))))
 958         (math-normalize a))
 959     0))
 960
 961 (defun math-add-objects-fancy (a b)
 962   (cond ((and (Math-numberp a) (Math-numberp b))
 963          (let ((aa (math-complex a))
 964                (bb (math-complex b)))
 965            (math-normalize
 966             (let ((res (list 'cplx
 967                              (math-add (nth 1 aa) (nth 1 bb))
 968                              (math-add (nth 2 aa) (nth 2 bb)))))
 969               (if (math-want-polar a b)
 970                   (math-polar res)
 971                 res)))))
 972         ((or (Math-vectorp a) (Math-vectorp b))
 973          (math-map-vec-2 'math-add a b))
 974         ((eq (car-safe a) 'sdev)
 975          (if (eq (car-safe b) 'sdev)
 976              (math-make-sdev (math-add (nth 1 a) (nth 1 b))
 977                              (math-hypot (nth 2 a) (nth 2 b)))
 978            (and (or (Math-scalarp b)
 979                     (not (Math-objvecp b)))
 980                 (math-make-sdev (math-add (nth 1 a) b) (nth 2 a)))))
 981         ((and (eq (car-safe b) 'sdev)
 982               (or (Math-scalarp a)
 983                   (not (Math-objvecp a))))
 984          (math-make-sdev (math-add a (nth 1 b)) (nth 2 b)))
 985         ((eq (car-safe a) 'intv)
 986          (if (eq (car-safe b) 'intv)
 987              (math-make-intv (logior (logand (nth 1 a) (nth 1 b))
 988                                      (if (equal (nth 2 a)
 989                                                 '(neg (var inf var-inf)))
 990                                          (logand (nth 1 a) 2) 0)
 991                                      (if (equal (nth 2 b)
 992                                                 '(neg (var inf var-inf)))
 993                                          (logand (nth 1 b) 2) 0)
 994                                      (if (equal (nth 3 a) '(var inf var-inf))
 995                                          (logand (nth 1 a) 1) 0)
 996                                      (if (equal (nth 3 b) '(var inf var-inf))
 997                                          (logand (nth 1 b) 1) 0))
 998                              (math-add (nth 2 a) (nth 2 b))
 999                              (math-add (nth 3 a) (nth 3 b)))
1000            (and (or (Math-anglep b)
1001                     (eq (car b) 'date)
1002                     (not (Math-objvecp b)))
1003                 (math-make-intv (nth 1 a)
1004                                 (math-add (nth 2 a) b)
1005                                 (math-add (nth 3 a) b)))))
1006         ((and (eq (car-safe b) 'intv)
1007               (or (Math-anglep a)
1008                   (eq (car a) 'date)
1009                   (not (Math-objvecp a))))
1010          (math-make-intv (nth 1 b)
1011                          (math-add a (nth 2 b))
1012                          (math-add a (nth 3 b))))
1013         ((eq (car-safe a) 'date)
1014          (cond ((eq (car-safe b) 'date)
1015                 (math-add (nth 1 a) (nth 1 b)))
1016                ((eq (car-safe b) 'hms)
1017                 (let ((parts (math-date-parts (nth 1 a))))
1018                   (list 'date
1019                         (math-add (car parts)   ; this minimizes roundoff
1020                                   (math-div (math-add
1021                                              (math-add (nth 1 parts)
1022                                                        (nth 2 parts))
1023                                              (math-add
1024                                               (math-mul (nth 1 b) 3600)
1025                                               (math-add (math-mul (nth 2 b) 60)
1026                                                         (nth 3 b))))
1027                                             86400)))))
1028                ((Math-realp b)
1029                 (list 'date (math-add (nth 1 a) b)))
1030                (t nil)))
1031         ((eq (car-safe b) 'date)
1032          (math-add-objects-fancy b a))
1033         ((and (eq (car-safe a) 'mod)
1034               (eq (car-safe b) 'mod)
1035               (equal (nth 2 a) (nth 2 b)))
1036          (math-make-mod (math-add (nth 1 a) (nth 1 b)) (nth 2 a)))
1037         ((and (eq (car-safe a) 'mod)
1038               (Math-anglep b))
1039          (math-make-mod (math-add (nth 1 a) b) (nth 2 a)))
1040         ((and (eq (car-safe b) 'mod)
1041               (Math-anglep a))
1042          (math-make-mod (math-add a (nth 1 b)) (nth 2 b)))
1043         ((and (or (eq (car-safe a) 'hms) (eq (car-safe b) 'hms))
1044               (and (Math-anglep a) (Math-anglep b)))
1045          (or (eq (car-safe a) 'hms) (setq a (math-to-hms a)))
1046          (or (eq (car-safe b) 'hms) (setq b (math-to-hms b)))
1047          (math-normalize
1048           (if (math-negp a)
1049               (math-neg (math-add (math-neg a) (math-neg b)))
1050             (if (math-negp b)
1051                 (let* ((s (math-add (nth 3 a) (nth 3 b)))
1052                        (m (math-add (nth 2 a) (nth 2 b)))
1053                        (h (math-add (nth 1 a) (nth 1 b))))
1054                   (if (math-negp s)
1055                       (setq s (math-add s 60)
1056                             m (math-add m -1)))
1057                   (if (math-negp m)
1058                       (setq m (math-add m 60)
1059                             h (math-add h -1)))
1060                   (if (math-negp h)
1061                       (math-add b a)
1062                     (list 'hms h m s)))
1063               (let* ((s (math-add (nth 3 a) (nth 3 b)))
1064                      (m (math-add (nth 2 a) (nth 2 b)))
1065                      (h (math-add (nth 1 a) (nth 1 b))))
1066                 (list 'hms h m s))))))
1067         (t (calc-record-why "*Incompatible arguments for +" a b))))
1068
1069 (defun math-add-symb-fancy (a b)
1070   (or (and math-simplify-only
1071            (not (equal a math-simplify-only))
1072            (list '+ a b))
1073       (and (eq (car-safe b) '+)
1074            (math-add (math-add a (nth 1 b))
1075                      (nth 2 b)))
1076       (and (eq (car-safe b) '-)
1077            (math-sub (math-add a (nth 1 b))
1078                      (nth 2 b)))
1079       (and (eq (car-safe b) 'neg)
1080            (eq (car-safe (nth 1 b)) '+)
1081            (math-sub (math-sub a (nth 1 (nth 1 b)))
1082                      (nth 2 (nth 1 b))))
1083       (and (or (and (Math-vectorp a) (math-known-scalarp b))
1084                (and (Math-vectorp b) (math-known-scalarp a)))
1085            (math-map-vec-2 'math-add a b))
1086       (let ((inf (math-infinitep a)))
1087         (cond
1088          (inf
1089           (let ((inf2 (math-infinitep b)))
1090             (if inf2
1091                 (if (or (memq (nth 2 inf) '(var-uinf var-nan))
1092                         (memq (nth 2 inf2) '(var-uinf var-nan)))
1093                     '(var nan var-nan)
1094                   (let ((dir (math-infinite-dir a inf))
1095                         (dir2 (math-infinite-dir b inf2)))
1096                     (if (and (Math-objectp dir) (Math-objectp dir2))
1097                         (if (Math-equal dir dir2)
1098                             a
1099                           '(var nan var-nan)))))
1100               (if (and (equal a '(var inf var-inf))
1101                        (eq (car-safe b) 'intv)
1102                        (memq (nth 1 b) '(2 3))
1103                        (equal (nth 2 b) '(neg (var inf var-inf))))
1104                   (list 'intv 3 (nth 2 b) a)
1105                 (if (and (equal a '(neg (var inf var-inf)))
1106                          (eq (car-safe b) 'intv)
1107                          (memq (nth 1 b) '(1 3))
1108                          (equal (nth 3 b) '(var inf var-inf)))
1109                     (list 'intv 3 a (nth 3 b))
1110                   a)))))
1111          ((math-infinitep b)
1112           (if (eq (car-safe a) 'intv)
1113               (math-add b a)
1114             b))
1115          ((eq (car-safe a) '+)
1116           (let ((temp (math-combine-sum (nth 2 a) b nil nil t)))
1117             (and temp
1118                  (math-add (nth 1 a) temp))))
1119          ((eq (car-safe a) '-)
1120           (let ((temp (math-combine-sum (nth 2 a) b t nil t)))
1121             (and temp
1122                  (math-add (nth 1 a) temp))))
1123          ((and (Math-objectp a) (Math-objectp b))
1124           nil)
1125          (t
1126           (math-combine-sum a b nil nil nil))))
1127       (and (Math-looks-negp b)
1128            (list '- a (math-neg b)))
1129       (and (Math-looks-negp a)
1130            (list '- b (math-neg a)))
1131       (and (eq (car-safe a) 'calcFunc-idn)
1132            (= (length a) 2)
1133            (or (and (eq (car-safe b) 'calcFunc-idn)
1134                     (= (length b) 2)
1135                     (list 'calcFunc-idn (math-add (nth 1 a) (nth 1 b))))
1136                (and (math-square-matrixp b)
1137                     (math-add (math-mimic-ident (nth 1 a) b) b))
1138                (and (math-known-scalarp b)
1139                     (math-add (nth 1 a) b))))
1140       (and (eq (car-safe b) 'calcFunc-idn)
1141            (= (length a) 2)
1142            (or (and (math-square-matrixp a)
1143                     (math-add a (math-mimic-ident (nth 1 b) a)))
1144                (and (math-known-scalarp a)
1145                     (math-add a (nth 1 b)))))
1146       (list '+ a b)))
1147
1148
1149 (defun calcFunc-mul (&rest rest)
1150   (if rest
1151       (let ((a (car rest)))
1152         (while (setq rest (cdr rest))
1153           (setq a (list '* a (car rest))))
1154         (math-normalize a))
1155     1))
1156
1157 (defun math-mul-objects-fancy (a b)
1158   (cond ((and (Math-numberp a) (Math-numberp b))
1159          (math-normalize
1160           (if (math-want-polar a b)
1161               (let ((a (math-polar a))
1162                     (b (math-polar b)))
1163                 (list 'polar
1164                       (math-mul (nth 1 a) (nth 1 b))
1165                       (math-fix-circular (math-add (nth 2 a) (nth 2 b)))))
1166             (setq a (math-complex a)
1167                   b (math-complex b))
1168             (list 'cplx
1169                   (math-sub (math-mul (nth 1 a) (nth 1 b))
1170                             (math-mul (nth 2 a) (nth 2 b)))
1171                   (math-add (math-mul (nth 1 a) (nth 2 b))
1172                             (math-mul (nth 2 a) (nth 1 b)))))))
1173         ((Math-vectorp a)
1174          (if (Math-vectorp b)
1175              (if (math-matrixp a)
1176                  (if (math-matrixp b)
1177                      (if (= (length (nth 1 a)) (length b))
1178                          (math-mul-mats a b)
1179                        (math-dimension-error))
1180                    (if (= (length (nth 1 a)) 2)
1181                        (if (= (length a) (length b))
1182                            (math-mul-mats a (list 'vec b))
1183                          (math-dimension-error))
1184                      (if (= (length (nth 1 a)) (length b))
1185                          (math-mul-mat-vec a b)
1186                        (math-dimension-error))))
1187                (if (math-matrixp b)
1188                    (if (= (length a) (length b))
1189                        (nth 1 (math-mul-mats (list 'vec a) b))
1190                      (math-dimension-error))
1191                  (if (= (length a) (length b))
1192                      (math-dot-product a b)
1193                    (math-dimension-error))))
1194            (math-map-vec-2 'math-mul a b)))
1195         ((Math-vectorp b)
1196          (math-map-vec-2 'math-mul a b))
1197         ((eq (car-safe a) 'sdev)
1198          (if (eq (car-safe b) 'sdev)
1199              (math-make-sdev (math-mul (nth 1 a) (nth 1 b))
1200                              (math-hypot (math-mul (nth 2 a) (nth 1 b))
1201                                          (math-mul (nth 2 b) (nth 1 a))))
1202            (and (or (Math-scalarp b)
1203                     (not (Math-objvecp b)))
1204                 (math-make-sdev (math-mul (nth 1 a) b)
1205                                 (math-mul (nth 2 a) b)))))
1206         ((and (eq (car-safe b) 'sdev)
1207               (or (Math-scalarp a)
1208                   (not (Math-objvecp a))))
1209          (math-make-sdev (math-mul a (nth 1 b)) (math-mul a (nth 2 b))))
1210         ((and (eq (car-safe a) 'intv) (Math-anglep b))
1211          (if (Math-negp b)
1212              (math-neg (math-mul a (math-neg b)))
1213            (math-make-intv (nth 1 a)
1214                            (math-mul (nth 2 a) b)
1215                            (math-mul (nth 3 a) b))))
1216         ((and (eq (car-safe b) 'intv) (Math-anglep a))
1217          (math-mul b a))
1218         ((and (eq (car-safe a) 'intv) (math-intv-constp a)
1219               (eq (car-safe b) 'intv) (math-intv-constp b))
1220          (let ((lo (math-mul a (nth 2 b)))
1221                (hi (math-mul a (nth 3 b))))
1222            (or (eq (car-safe lo) 'intv)
1223                (setq lo (list 'intv (if (memq (nth 1 b) '(2 3)) 3 0) lo lo)))
1224            (or (eq (car-safe hi) 'intv)
1225                (setq hi (list 'intv (if (memq (nth 1 b) '(1 3)) 3 0) hi hi)))
1226            (math-combine-intervals
1227             (nth 2 lo) (and (or (memq (nth 1 b) '(2 3))
1228                                 (math-infinitep (nth 2 lo)))
1229                             (memq (nth 1 lo) '(2 3)))
1230             (nth 3 lo) (and (or (memq (nth 1 b) '(2 3))
1231                                 (math-infinitep (nth 3 lo)))
1232                             (memq (nth 1 lo) '(1 3)))
1233             (nth 2 hi) (and (or (memq (nth 1 b) '(1 3))
1234                                 (math-infinitep (nth 2 hi)))
1235                             (memq (nth 1 hi) '(2 3)))
1236             (nth 3 hi) (and (or (memq (nth 1 b) '(1 3))
1237                                 (math-infinitep (nth 3 hi)))
1238                             (memq (nth 1 hi) '(1 3))))))
1239         ((and (eq (car-safe a) 'mod)
1240               (eq (car-safe b) 'mod)
1241               (equal (nth 2 a) (nth 2 b)))
1242          (math-make-mod (math-mul (nth 1 a) (nth 1 b)) (nth 2 a)))
1243         ((and (eq (car-safe a) 'mod)
1244               (Math-anglep b))
1245          (math-make-mod (math-mul (nth 1 a) b) (nth 2 a)))
1246         ((and (eq (car-safe b) 'mod)
1247               (Math-anglep a))
1248          (math-make-mod (math-mul a (nth 1 b)) (nth 2 b)))
1249         ((and (eq (car-safe a) 'hms) (Math-realp b))
1250          (math-with-extra-prec 2
1251            (math-to-hms (math-mul (math-from-hms a 'deg) b) 'deg)))
1252         ((and (eq (car-safe b) 'hms) (Math-realp a))
1253          (math-mul b a))
1254         (t (calc-record-why "*Incompatible arguments for *" a b))))
1255
1256 ;;; Fast function to multiply floating-point numbers.
1257 (defun math-mul-float (a b)   ; [F F F]
1258   (math-make-float (math-mul (nth 1 a) (nth 1 b))
1259                    (+ (nth 2 a) (nth 2 b))))
1260
1261 (defun math-sqr-float (a)   ; [F F]
1262   (math-make-float (math-mul (nth 1 a) (nth 1 a))
1263                    (+ (nth 2 a) (nth 2 a))))
1264
1265 (defun math-intv-constp (a &optional finite)
1266   (and (or (Math-anglep (nth 2 a))
1267            (and (equal (nth 2 a) '(neg (var inf var-inf)))
1268                 (or (not finite)
1269                     (memq (nth 1 a) '(0 1)))))
1270        (or (Math-anglep (nth 3 a))
1271            (and (equal (nth 3 a) '(var inf var-inf))
1272                 (or (not finite)
1273                     (memq (nth 1 a) '(0 2)))))))
1274
1275 (defun math-mul-zero (a b)
1276   (if (math-known-matrixp b)
1277       (if (math-vectorp b)
1278           (math-map-vec-2 'math-mul a b)
1279         (math-mimic-ident 0 b))
1280     (if (math-infinitep b)
1281         '(var nan var-nan)
1282       (let ((aa nil) (bb nil))
1283         (if (and (eq (car-safe b) 'intv)
1284                  (progn
1285                    (and (equal (nth 2 b) '(neg (var inf var-inf)))
1286                         (memq (nth 1 b) '(2 3))
1287                         (setq aa (nth 2 b)))
1288                    (and (equal (nth 3 b) '(var inf var-inf))
1289                         (memq (nth 1 b) '(1 3))
1290                         (setq bb (nth 3 b)))
1291                    (or aa bb)))
1292             (if (or (math-posp a)
1293                     (and (math-zerop a)
1294                          (or (memq calc-infinite-mode '(-1 1))
1295                              (setq aa '(neg (var inf var-inf))
1296                                    bb '(var inf var-inf)))))
1297                 (list 'intv 3 (or aa 0) (or bb 0))
1298               (if (math-negp a)
1299                   (math-neg (list 'intv 3 (or aa 0) (or bb 0)))
1300                 '(var nan var-nan)))
1301           (if (or (math-floatp a) (math-floatp b)) '(float 0 0) 0))))))
1302
1303
1304 (defun math-mul-symb-fancy (a b)
1305   (or (and math-simplify-only
1306            (not (equal a math-simplify-only))
1307            (list '* a b))
1308       (and (Math-equal-int a 1)
1309            b)
1310       (and (Math-equal-int a -1)
1311            (math-neg b))
1312       (and (or (and (Math-vectorp a) (math-known-scalarp b))
1313                (and (Math-vectorp b) (math-known-scalarp a)))
1314            (math-map-vec-2 'math-mul a b))
1315       (and (Math-objectp b) (not (Math-objectp a))
1316            (math-mul b a))
1317       (and (eq (car-safe a) 'neg)
1318            (math-neg (math-mul (nth 1 a) b)))
1319       (and (eq (car-safe b) 'neg)
1320            (math-neg (math-mul a (nth 1 b))))
1321       (and (eq (car-safe a) '*)
1322            (math-mul (nth 1 a)
1323                      (math-mul (nth 2 a) b)))
1324       (and (eq (car-safe a) '^)
1325            (Math-looks-negp (nth 2 a))
1326            (not (and (eq (car-safe b) '^) (Math-looks-negp (nth 2 b))))
1327            (math-known-scalarp b t)
1328            (math-div b (math-normalize
1329                         (list '^ (nth 1 a) (math-neg (nth 2 a))))))
1330       (and (eq (car-safe b) '^)
1331            (Math-looks-negp (nth 2 b))
1332            (not (and (eq (car-safe a) '^) (Math-looks-negp (nth 2 a))))
1333            (math-div a (math-normalize
1334                         (list '^ (nth 1 b) (math-neg (nth 2 b))))))
1335       (and (eq (car-safe a) '/)
1336            (or (math-known-scalarp a t) (math-known-scalarp b t))
1337            (let ((temp (math-combine-prod (nth 2 a) b t nil t)))
1338              (if temp
1339                  (math-mul (nth 1 a) temp)
1340                (math-div (math-mul (nth 1 a) b) (nth 2 a)))))
1341       (and (eq (car-safe b) '/)
1342            (math-div (math-mul a (nth 1 b)) (nth 2 b)))
1343       (and (eq (car-safe b) '+)
1344            (Math-numberp a)
1345            (or (Math-numberp (nth 1 b))
1346                (Math-numberp (nth 2 b)))
1347            (math-add (math-mul a (nth 1 b))
1348                      (math-mul a (nth 2 b))))
1349       (and (eq (car-safe b) '-)
1350            (Math-numberp a)
1351            (or (Math-numberp (nth 1 b))
1352                (Math-numberp (nth 2 b)))
1353            (math-sub (math-mul a (nth 1 b))
1354                      (math-mul a (nth 2 b))))
1355       (and (eq (car-safe b) '*)
1356            (Math-numberp (nth 1 b))
1357            (not (Math-numberp a))
1358            (math-mul (nth 1 b) (math-mul a (nth 2 b))))
1359       (and (eq (car-safe a) 'calcFunc-idn)
1360            (= (length a) 2)
1361            (or (and (eq (car-safe b) 'calcFunc-idn)
1362                     (= (length b) 2)
1363                     (list 'calcFunc-idn (math-mul (nth 1 a) (nth 1 b))))
1364                (and (math-known-scalarp b)
1365                     (list 'calcFunc-idn (math-mul (nth 1 a) b)))
1366                (and (math-known-matrixp b)
1367                     (math-mul (nth 1 a) b))))
1368       (and (eq (car-safe b) 'calcFunc-idn)
1369            (= (length b) 2)
1370            (or (and (math-known-scalarp a)
1371                     (list 'calcFunc-idn (math-mul a (nth 1 b))))
1372                (and (math-known-matrixp a)
1373                     (math-mul a (nth 1 b)))))
1374       (and (math-looks-negp b)
1375            (math-mul (math-neg a) (math-neg b)))
1376       (and (eq (car-safe b) '-)
1377            (math-looks-negp a)
1378            (math-mul (math-neg a) (math-neg b)))
1379       (cond
1380        ((eq (car-safe b) '*)
1381         (let ((temp (math-combine-prod a (nth 1 b) nil nil t)))
1382           (and temp
1383                (math-mul temp (nth 2 b)))))
1384        (t
1385         (math-combine-prod a b nil nil nil)))
1386       (and (equal a '(var nan var-nan))
1387            a)
1388       (and (equal b '(var nan var-nan))
1389            b)
1390       (and (equal a '(var uinf var-uinf))
1391            a)
1392       (and (equal b '(var uinf var-uinf))
1393            b)
1394       (and (equal b '(var inf var-inf))
1395            (let ((s1 (math-possible-signs a)))
1396              (cond ((eq s1 4)
1397                     b)
1398                    ((eq s1 6)
1399                     '(intv 3 0 (var inf var-inf)))
1400                    ((eq s1 1)
1401                     (math-neg b))
1402                    ((eq s1 3)
1403                     '(intv 3 (neg (var inf var-inf)) 0))
1404                    ((and (eq (car a) 'intv) (math-intv-constp a))
1405                     '(intv 3 (neg (var inf var-inf)) (var inf var-inf)))
1406                    ((and (eq (car a) 'cplx)
1407                          (math-zerop (nth 1 a)))
1408                     (list '* (list 'cplx 0 (calcFunc-sign (nth 2 a))) b))
1409                    ((eq (car a) 'polar)
1410                     (list '* (list 'polar 1 (nth 2 a)) b)))))
1411       (and (equal a '(var inf var-inf))
1412            (math-mul b a))
1413       (list '* a b)))
1414
1415
1416 (defun calcFunc-div (a &rest rest)
1417   (while rest
1418     (setq a (list '/ a (car rest))
1419           rest (cdr rest)))
1420   (math-normalize a))
1421
1422 (defun math-div-objects-fancy (a b)
1423   (cond ((and (Math-numberp a) (Math-numberp b))
1424          (math-normalize
1425           (cond ((math-want-polar a b)
1426                  (let ((a (math-polar a))
1427                        (b (math-polar b)))
1428                    (list 'polar
1429                          (math-div (nth 1 a) (nth 1 b))
1430                          (math-fix-circular (math-sub (nth 2 a)
1431                                                       (nth 2 b))))))
1432                 ((Math-realp b)
1433                  (setq a (math-complex a))
1434                  (list 'cplx (math-div (nth 1 a) b)
1435                        (math-div (nth 2 a) b)))
1436                 (t
1437                  (setq a (math-complex a)
1438                        b (math-complex b))
1439                  (math-div
1440                   (list 'cplx
1441                         (math-add (math-mul (nth 1 a) (nth 1 b))
1442                                   (math-mul (nth 2 a) (nth 2 b)))
1443                         (math-sub (math-mul (nth 2 a) (nth 1 b))
1444                                   (math-mul (nth 1 a) (nth 2 b))))
1445                   (math-add (math-sqr (nth 1 b))
1446                             (math-sqr (nth 2 b))))))))
1447         ((math-matrixp b)
1448          (if (math-square-matrixp b)
1449              (let ((n1 (length b)))
1450                (if (Math-vectorp a)
1451                    (if (math-matrixp a)
1452                        (if (= (length a) n1)
1453                            (math-lud-solve (math-matrix-lud b) a b)
1454                          (if (= (length (nth 1 a)) n1)
1455                              (math-transpose
1456                               (math-lud-solve (math-matrix-lud
1457                                                (math-transpose b))
1458                                               (math-transpose a) b))
1459                            (math-dimension-error)))
1460                      (if (= (length a) n1)
1461                          (math-mat-col (math-lud-solve (math-matrix-lud b)
1462                                                        (math-col-matrix a) b)
1463                                        1)
1464                        (math-dimension-error)))
1465                  (if (Math-equal-int a 1)
1466                      (calcFunc-inv b)
1467                    (math-mul a (calcFunc-inv b)))))
1468            (math-reject-arg b 'square-matrixp)))
1469         ((and (Math-vectorp a) (Math-objectp b))
1470          (math-map-vec-2 'math-div a b))
1471         ((eq (car-safe a) 'sdev)
1472          (if (eq (car-safe b) 'sdev)
1473              (let ((x (math-div (nth 1 a) (nth 1 b))))
1474                (math-make-sdev x
1475                                (math-div (math-hypot (nth 2 a)
1476                                                      (math-mul (nth 2 b) x))
1477                                          (nth 1 b))))
1478            (if (or (Math-scalarp b)
1479                    (not (Math-objvecp b)))
1480                (math-make-sdev (math-div (nth 1 a) b) (math-div (nth 2 a) b))
1481              (math-reject-arg 'realp b))))
1482         ((and (eq (car-safe b) 'sdev)
1483               (or (Math-scalarp a)
1484                   (not (Math-objvecp a))))
1485          (let ((x (math-div a (nth 1 b))))
1486            (math-make-sdev x
1487                            (math-div (math-mul (nth 2 b) x) (nth 1 b)))))
1488         ((and (eq (car-safe a) 'intv) (Math-anglep b))
1489          (if (Math-negp b)
1490              (math-neg (math-div a (math-neg b)))
1491            (math-make-intv (nth 1 a)
1492                            (math-div (nth 2 a) b)
1493                            (math-div (nth 3 a) b))))
1494         ((and (eq (car-safe b) 'intv) (Math-anglep a))
1495          (if (or (Math-posp (nth 2 b))
1496                  (and (Math-zerop (nth 2 b)) (or (memq (nth 1 b) '(0 1))
1497                                                  calc-infinite-mode)))
1498              (if (Math-negp a)
1499                  (math-neg (math-div (math-neg a) b))
1500                (let ((calc-infinite-mode 1))
1501                  (math-make-intv (aref [0 2 1 3] (nth 1 b))
1502                                  (math-div a (nth 3 b))
1503                                  (math-div a (nth 2 b)))))
1504            (if (or (Math-negp (nth 3 b))
1505                    (and (Math-zerop (nth 3 b)) (or (memq (nth 1 b) '(0 2))
1506                                                    calc-infinite-mode)))
1507                (math-neg (math-div a (math-neg b)))
1508              (if calc-infinite-mode
1509                  '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
1510                (math-reject-arg b "*Division by zero")))))
1511         ((and (eq (car-safe a) 'intv) (math-intv-constp a)
1512               (eq (car-safe b) 'intv) (math-intv-constp b))
1513          (if (or (Math-posp (nth 2 b))
1514                  (and (Math-zerop (nth 2 b)) (or (memq (nth 1 b) '(0 1))
1515                                                  calc-infinite-mode)))
1516              (let* ((calc-infinite-mode 1)
1517                     (lo (math-div a (nth 2 b)))
1518                     (hi (math-div a (nth 3 b))))
1519                (or (eq (car-safe lo) 'intv)
1520                    (setq lo (list 'intv (if (memq (nth 1 b) '(2 3)) 3 0)
1521                                   lo lo)))
1522                (or (eq (car-safe hi) 'intv)
1523                    (setq hi (list 'intv (if (memq (nth 1 b) '(1 3)) 3 0)
1524                                   hi hi)))
1525                (math-combine-intervals
1526                 (nth 2 lo) (and (or (memq (nth 1 b) '(2 3))
1527                                     (and (math-infinitep (nth 2 lo))
1528                                          (not (math-zerop (nth 2 b)))))
1529                                 (memq (nth 1 lo) '(2 3)))
1530                 (nth 3 lo) (and (or (memq (nth 1 b) '(2 3))
1531                                     (and (math-infinitep (nth 3 lo))
1532                                          (not (math-zerop (nth 2 b)))))
1533                                 (memq (nth 1 lo) '(1 3)))
1534                 (nth 2 hi) (and (or (memq (nth 1 b) '(1 3))
1535                                     (and (math-infinitep (nth 2 hi))
1536                                          (not (math-zerop (nth 3 b)))))
1537                                 (memq (nth 1 hi) '(2 3)))
1538                 (nth 3 hi) (and (or (memq (nth 1 b) '(1 3))
1539                                     (and (math-infinitep (nth 3 hi))
1540                                          (not (math-zerop (nth 3 b)))))
1541                                 (memq (nth 1 hi) '(1 3)))))
1542            (if (or (Math-negp (nth 3 b))
1543                    (and (Math-zerop (nth 3 b)) (or (memq (nth 1 b) '(0 2))
1544                                                    calc-infinite-mode)))
1545                (math-neg (math-div a (math-neg b)))
1546              (if calc-infinite-mode
1547                  '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
1548                (math-reject-arg b "*Division by zero")))))
1549         ((and (eq (car-safe a) 'mod)
1550               (eq (car-safe b) 'mod)
1551               (equal (nth 2 a) (nth 2 b)))
1552          (math-make-mod (math-div-mod (nth 1 a) (nth 1 b) (nth 2 a))
1553                         (nth 2 a)))
1554         ((and (eq (car-safe a) 'mod)
1555               (Math-anglep b))
1556          (math-make-mod (math-div-mod (nth 1 a) b (nth 2 a)) (nth 2 a)))
1557         ((and (eq (car-safe b) 'mod)
1558               (Math-anglep a))
1559          (math-make-mod (math-div-mod a (nth 1 b) (nth 2 b)) (nth 2 b)))
1560         ((eq (car-safe a) 'hms)
1561          (if (eq (car-safe b) 'hms)
1562              (math-with-extra-prec 1
1563                (math-div (math-from-hms a 'deg)
1564                          (math-from-hms b 'deg)))
1565            (math-with-extra-prec 2
1566              (math-to-hms (math-div (math-from-hms a 'deg) b) 'deg))))
1567         (t (calc-record-why "*Incompatible arguments for /" a b))))
1568
1569 (defun math-div-by-zero (a b)
1570   (if (math-infinitep a)
1571       (if (or (equal a '(var nan var-nan))
1572               (equal b '(var uinf var-uinf))
1573               (memq calc-infinite-mode '(-1 1)))
1574           a
1575         '(var uinf var-uinf))
1576     (if calc-infinite-mode
1577         (if (math-zerop a)
1578             '(var nan var-nan)
1579           (if (eq calc-infinite-mode 1)
1580               (math-mul a '(var inf var-inf))
1581             (if (eq calc-infinite-mode -1)
1582                 (math-mul a '(neg (var inf var-inf)))
1583               (if (eq (car-safe a) 'intv)
1584                   '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
1585                 '(var uinf var-uinf)))))
1586       (math-reject-arg a "*Division by zero"))))
1587
1588 (defun math-div-zero (a b)
1589   (if (math-known-matrixp b)
1590       (if (math-vectorp b)
1591           (math-map-vec-2 'math-div a b)
1592         (math-mimic-ident 0 b))
1593     (if (equal b '(var nan var-nan))
1594         b
1595       (if (and (eq (car-safe b) 'intv) (math-intv-constp b)
1596                (not (math-posp b)) (not (math-negp b)))
1597           (if calc-infinite-mode
1598               (list 'intv 3
1599                     (if (and (math-zerop (nth 2 b))
1600                              (memq calc-infinite-mode '(1 -1)))
1601                         (nth 2 b) '(neg (var inf var-inf)))
1602                     (if (and (math-zerop (nth 3 b))
1603                              (memq calc-infinite-mode '(1 -1)))
1604                         (nth 3 b) '(var inf var-inf)))
1605             (math-reject-arg b "*Division by zero"))
1606         a))))
1607
1608 (defun math-div-symb-fancy (a b)
1609   (or (and math-simplify-only
1610            (not (equal a math-simplify-only))
1611            (list '/ a b))
1612       (and (Math-equal-int b 1) a)
1613       (and (Math-equal-int b -1) (math-neg a))
1614       (and (Math-vectorp a) (math-known-scalarp b)
1615            (math-map-vec-2 'math-div a b))
1616       (and (eq (car-safe b) '^)
1617            (or (Math-looks-negp (nth 2 b)) (Math-equal-int a 1))
1618            (math-mul a (math-normalize
1619                         (list '^ (nth 1 b) (math-neg (nth 2 b))))))
1620       (and (eq (car-safe a) 'neg)
1621            (math-neg (math-div (nth 1 a) b)))
1622       (and (eq (car-safe b) 'neg)
1623            (math-neg (math-div a (nth 1 b))))
1624       (and (eq (car-safe a) '/)
1625            (math-div (nth 1 a) (math-mul (nth 2 a) b)))
1626       (and (eq (car-safe b) '/)
1627            (or (math-known-scalarp (nth 1 b) t)
1628                (math-known-scalarp (nth 2 b) t))
1629            (math-div (math-mul a (nth 2 b)) (nth 1 b)))
1630       (and (eq (car-safe b) 'frac)
1631            (math-mul (math-make-frac (nth 2 b) (nth 1 b)) a))
1632       (and (eq (car-safe a) '+)
1633            (or (Math-numberp (nth 1 a))
1634                (Math-numberp (nth 2 a)))
1635            (Math-numberp b)
1636            (math-add (math-div (nth 1 a) b)
1637                      (math-div (nth 2 a) b)))
1638       (and (eq (car-safe a) '-)
1639            (or (Math-numberp (nth 1 a))
1640                (Math-numberp (nth 2 a)))
1641            (Math-numberp b)
1642            (math-sub (math-div (nth 1 a) b)
1643                      (math-div (nth 2 a) b)))
1644       (and (or (eq (car-safe a) '-)
1645                (math-looks-negp a))
1646            (math-looks-negp b)
1647            (math-div (math-neg a) (math-neg b)))
1648       (and (eq (car-safe b) '-)
1649            (math-looks-negp a)
1650            (math-div (math-neg a) (math-neg b)))
1651       (and (eq (car-safe a) 'calcFunc-idn)
1652            (= (length a) 2)
1653            (or (and (eq (car-safe b) 'calcFunc-idn)
1654                     (= (length b) 2)
1655                     (list 'calcFunc-idn (math-div (nth 1 a) (nth 1 b))))
1656                (and (math-known-scalarp b)
1657                     (list 'calcFunc-idn (math-div (nth 1 a) b)))
1658                (and (math-known-matrixp b)
1659                     (math-div (nth 1 a) b))))
1660       (and (eq (car-safe b) 'calcFunc-idn)
1661            (= (length b) 2)
1662            (or (and (math-known-scalarp a)
1663                     (list 'calcFunc-idn (math-div a (nth 1 b))))
1664                (and (math-known-matrixp a)
1665                     (math-div a (nth 1 b)))))
1666       (if (and calc-matrix-mode
1667                (or (math-known-matrixp a) (math-known-matrixp b)))
1668           (math-combine-prod a b nil t nil)
1669         (if (eq (car-safe a) '*)
1670             (if (eq (car-safe b) '*)
1671                 (let ((c (math-combine-prod (nth 1 a) (nth 1 b) nil t t)))
1672                   (and c
1673                        (math-div (math-mul c (nth 2 a)) (nth 2 b))))
1674               (let ((c (math-combine-prod (nth 1 a) b nil t t)))
1675                 (and c
1676                      (math-mul c (nth 2 a)))))
1677           (if (eq (car-safe b) '*)
1678               (let ((c (math-combine-prod a (nth 1 b) nil t t)))
1679                 (and c
1680                      (math-div c (nth 2 b))))
1681             (math-combine-prod a b nil t nil))))
1682       (and (math-infinitep a)
1683            (if (math-infinitep b)
1684                '(var nan var-nan)
1685              (if (or (equal a '(var nan var-nan))
1686                      (equal a '(var uinf var-uinf)))
1687                  a
1688                (if (equal a '(var inf var-inf))
1689                    (if (or (math-posp b)
1690                            (and (eq (car-safe b) 'intv)
1691                                 (math-zerop (nth 2 b))))
1692                        (if (and (eq (car-safe b) 'intv)
1693                                 (not (math-intv-constp b t)))
1694                            '(intv 3 0 (var inf var-inf))
1695                          a)
1696                      (if (or (math-negp b)
1697                              (and (eq (car-safe b) 'intv)
1698                               (math-zerop (nth 3 b))))
1699                          (if (and (eq (car-safe b) 'intv)
1700                                   (not (math-intv-constp b t)))
1701                              '(intv 3 (neg (var inf var-inf)) 0)
1702                            (math-neg a))
1703                        (if (and (eq (car-safe b) 'intv)
1704                                 (math-negp (nth 2 b)) (math-posp (nth 3 b)))
1705                            '(intv 3 (neg (var inf var-inf))
1706                                   (var inf var-inf)))))))))
1707       (and (math-infinitep b)
1708            (if (equal b '(var nan var-nan))
1709                b
1710              (let ((calc-infinite-mode 1))
1711                (math-mul-zero b a))))
1712       (list '/ a b)))
1713
1714
1715 (defun calcFunc-mod (a b)
1716   (math-normalize (list '% a b)))
1717
1718 (defun math-mod-fancy (a b)
1719   (cond ((equal b '(var inf var-inf))
1720          (if (or (math-posp a) (math-zerop a))
1721              a
1722            (if (math-negp a)
1723                b
1724              (if (eq (car-safe a) 'intv)
1725                  (if (math-negp (nth 2 a))
1726                      '(intv 3 0 (var inf var-inf))
1727                    a)
1728                (list '% a b)))))
1729         ((and (eq (car-safe a) 'mod) (Math-realp b) (math-posp b))
1730          (math-make-mod (nth 1 a) b))
1731         ((and (eq (car-safe a) 'intv) (math-intv-constp a t) (math-posp b))
1732          (math-mod-intv a b))
1733         (t
1734          (if (Math-anglep a)
1735              (calc-record-why 'anglep b)
1736            (calc-record-why 'anglep a))
1737          (list '% a b))))
1738
1739
1740 (defun calcFunc-pow (a b)
1741   (math-normalize (list '^ a b)))
1742
1743 (defun math-pow-of-zero (a b)
1744   (if (Math-zerop b)
1745       (if calc-infinite-mode
1746           '(var nan var-nan)
1747         (math-reject-arg (list '^ a b) "*Indeterminate form"))
1748     (if (math-floatp b) (setq a (math-float a)))
1749     (if (math-posp b)
1750         a
1751       (if (math-negp b)
1752           (math-div 1 a)
1753         (if (math-infinitep b)
1754             '(var nan var-nan)
1755           (if (and (eq (car b) 'intv) (math-intv-constp b)
1756                    calc-infinite-mode)
1757               '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
1758             (if (math-objectp b)
1759                 (list '^ a b)
1760               a)))))))
1761
1762 (defun math-pow-zero (a b)
1763   (if (eq (car-safe a) 'mod)
1764       (math-make-mod 1 (nth 2 a))
1765     (if (math-known-matrixp a)
1766         (math-mimic-ident 1 a)
1767       (if (math-infinitep a)
1768           '(var nan var-nan)
1769         (if (and (eq (car a) 'intv) (math-intv-constp a)
1770                  (or (and (not (math-posp a)) (not (math-negp a)))
1771                      (not (math-intv-constp a t))))
1772             '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
1773           (if (or (math-floatp a) (math-floatp b))
1774               '(float 1 0) 1))))))
1775
1776 (defun math-pow-fancy (a b)
1777   (cond ((and (Math-numberp a) (Math-numberp b))
1778          (or (if (memq (math-quarter-integer b) '(1 2 3))
1779                  (let ((sqrt (math-sqrt (if (math-floatp b)
1780                                             (math-float a) a))))
1781                    (and (Math-numberp sqrt)
1782                         (math-pow sqrt (math-mul 2 b))))
1783                (and (eq (car b) 'frac)
1784                     (integerp (nth 2 b))
1785                     (<= (nth 2 b) 10)
1786                     (let ((root (math-nth-root a (nth 2 b))))
1787                       (and root (math-ipow root (nth 1 b))))))
1788              (and (or (eq a 10) (equal a '(float 1 1)))
1789                   (math-num-integerp b)
1790                   (calcFunc-scf '(float 1 0) b))
1791              (and calc-symbolic-mode
1792                   (list '^ a b))
1793              (math-with-extra-prec 2
1794                (math-exp-raw
1795                 (math-float (math-mul b (math-ln-raw (math-float a))))))))
1796         ((or (not (Math-objvecp a))
1797              (not (Math-objectp b)))
1798          (let (temp)
1799            (cond ((and math-simplify-only
1800                        (not (equal a math-simplify-only)))
1801                   (list '^ a b))
1802                  ((and (eq (car-safe a) '*)
1803                        (or (math-known-num-integerp b)
1804                            (math-known-nonnegp (nth 1 a))
1805                            (math-known-nonnegp (nth 2 a))))
1806                   (math-mul (math-pow (nth 1 a) b)
1807                             (math-pow (nth 2 a) b)))
1808                  ((and (eq (car-safe a) '/)
1809                        (or (math-known-num-integerp b)
1810                            (math-known-nonnegp (nth 2 a))))
1811                   (math-div (math-pow (nth 1 a) b)
1812                             (math-pow (nth 2 a) b)))
1813                  ((and (eq (car-safe a) '/)
1814                        (math-known-nonnegp (nth 1 a))
1815                        (not (math-equal-int (nth 1 a) 1)))
1816                   (math-mul (math-pow (nth 1 a) b)
1817                             (math-pow (math-div 1 (nth 2 a)) b)))
1818                  ((and (eq (car-safe a) '^)
1819                        (or (math-known-num-integerp b)
1820                            (math-known-nonnegp (nth 1 a))))
1821                   (math-pow (nth 1 a) (math-mul (nth 2 a) b)))
1822                  ((and (eq (car-safe a) 'calcFunc-sqrt)
1823                        (or (math-known-num-integerp b)
1824                            (math-known-nonnegp (nth 1 a))))
1825                   (math-pow (nth 1 a) (math-div b 2)))
1826                  ((and (eq (car-safe a) '^)
1827                        (math-known-evenp (nth 2 a))
1828                        (memq (math-quarter-integer b) '(1 2 3))
1829                        (math-known-realp (nth 1 a)))
1830                   (math-abs (math-pow (nth 1 a) (math-mul (nth 2 a) b))))
1831                  ((and (math-looks-negp a)
1832                        (math-known-integerp b)
1833                        (setq temp (or (and (math-known-evenp b)
1834                                            (math-pow (math-neg a) b))
1835                                       (and (math-known-oddp b)
1836                                            (math-neg (math-pow (math-neg a)
1837                                                                b))))))
1838                   temp)
1839                  ((and (eq (car-safe a) 'calcFunc-abs)
1840                        (math-known-realp (nth 1 a))
1841                        (math-known-evenp b))
1842                   (math-pow (nth 1 a) b))
1843                  ((math-infinitep a)
1844                   (cond ((equal a '(var nan var-nan))
1845                          a)
1846                         ((eq (car a) 'neg)
1847                          (math-mul (math-pow -1 b) (math-pow (nth 1 a) b)))
1848                         ((math-posp b)
1849                          a)
1850                         ((math-negp b)
1851                          (if (math-floatp b) '(float 0 0) 0))
1852                         ((and (eq (car-safe b) 'intv)
1853                               (math-intv-constp b))
1854                          '(intv 3 0 (var inf var-inf)))
1855                         (t
1856                          '(var nan var-nan))))
1857                  ((math-infinitep b)
1858                   (let (scale)
1859                     (cond ((math-negp b)
1860                            (math-pow (math-div 1 a) (math-neg b)))
1861                           ((not (math-posp b))
1862                            '(var nan var-nan))
1863                           ((math-equal-int (setq scale (calcFunc-abssqr a)) 1)
1864                            '(var nan var-nan))
1865                           ((Math-lessp scale 1)
1866                            (if (math-floatp a) '(float 0 0) 0))
1867                           ((Math-lessp 1 a)
1868                            b)
1869                           ((Math-lessp a -1)
1870                            '(var uinf var-uinf))
1871                           ((and (eq (car a) 'intv)
1872                                 (math-intv-constp a))
1873                            (if (Math-lessp -1 a)
1874                                (if (math-equal-int (nth 3 a) 1)
1875                                    '(intv 3 0 1)
1876                                  '(intv 3 0 (var inf var-inf)))
1877                              '(intv 3 (neg (var inf var-inf))
1878                                     (var inf var-inf))))
1879                           (t (list '^ a b)))))
1880                  ((and (eq (car-safe a) 'calcFunc-idn)
1881                        (= (length a) 2)
1882                        (math-known-num-integerp b))
1883                   (list 'calcFunc-idn (math-pow (nth 1 a) b)))
1884                  (t (if (Math-objectp a)
1885                         (calc-record-why 'objectp b)
1886                       (calc-record-why 'objectp a))
1887                     (list '^ a b)))))
1888         ((and (eq (car-safe a) 'sdev) (eq (car-safe b) 'sdev))
1889          (if (and (math-constp a) (math-constp b))
1890              (math-with-extra-prec 2
1891                (let* ((ln (math-ln-raw (math-float (nth 1 a))))
1892                       (pow (math-exp-raw
1893                             (math-float (math-mul (nth 1 b) ln)))))
1894                  (math-make-sdev
1895                   pow
1896                   (math-mul
1897                    pow
1898                    (math-hypot (math-mul (nth 2 a)
1899                                          (math-div (nth 1 b) (nth 1 a)))
1900                                (math-mul (nth 2 b) ln))))))
1901            (let ((pow (math-pow (nth 1 a) (nth 1 b))))
1902              (math-make-sdev
1903               pow
1904               (math-mul pow
1905                         (math-hypot (math-mul (nth 2 a)
1906                                               (math-div (nth 1 b) (nth 1 a)))
1907                                     (math-mul (nth 2 b) (calcFunc-ln
1908                                                          (nth 1 a)))))))))
1909         ((and (eq (car-safe a) 'sdev) (Math-numberp b))
1910          (if (math-constp a)
1911              (math-with-extra-prec 2
1912                (let ((pow (math-pow (nth 1 a) (math-sub b 1))))
1913                  (math-make-sdev (math-mul pow (nth 1 a))
1914                                  (math-mul pow (math-mul (nth 2 a) b)))))
1915            (math-make-sdev (math-pow (nth 1 a) b)
1916                            (math-mul (math-pow (nth 1 a) (math-add b -1))
1917                                      (math-mul (nth 2 a) b)))))
1918         ((and (eq (car-safe b) 'sdev) (Math-numberp a))
1919          (math-with-extra-prec 2
1920            (let* ((ln (math-ln-raw (math-float a)))
1921                   (pow (calcFunc-exp (math-mul (nth 1 b) ln))))
1922              (math-make-sdev pow (math-mul pow (math-mul (nth 2 b) ln))))))
1923         ((and (eq (car-safe a) 'intv) (math-intv-constp a)
1924               (Math-realp b)
1925               (or (Math-natnump b)
1926                   (Math-posp (nth 2 a))
1927                   (and (math-zerop (nth 2 a))
1928                        (or (Math-posp b)
1929                            (and (Math-integerp b) calc-infinite-mode)))
1930                   (Math-negp (nth 3 a))
1931                   (and (math-zerop (nth 3 a))
1932                        (or (Math-posp b)
1933                            (and (Math-integerp b) calc-infinite-mode)))))
1934          (if (math-evenp b)
1935              (setq a (math-abs a)))
1936          (let ((calc-infinite-mode (if (math-zerop (nth 3 a)) -1 1)))
1937            (math-sort-intv (nth 1 a)
1938                            (math-pow (nth 2 a) b)
1939                            (math-pow (nth 3 a) b))))
1940         ((and (eq (car-safe b) 'intv) (math-intv-constp b)
1941               (Math-realp a) (Math-posp a))
1942          (math-sort-intv (nth 1 b)
1943                          (math-pow a (nth 2 b))
1944                          (math-pow a (nth 3 b))))
1945         ((and (eq (car-safe a) 'intv) (math-intv-constp a)
1946               (eq (car-safe b) 'intv) (math-intv-constp b)
1947               (or (and (not (Math-negp (nth 2 a)))
1948                        (not (Math-negp (nth 2 b))))
1949                   (and (Math-posp (nth 2 a))
1950                        (not (Math-posp (nth 3 b))))))
1951          (let ((lo (math-pow a (nth 2 b)))
1952                (hi (math-pow a (nth 3 b))))
1953            (or (eq (car-safe lo) 'intv)
1954                (setq lo (list 'intv (if (memq (nth 1 b) '(2 3)) 3 0) lo lo)))
1955            (or (eq (car-safe hi) 'intv)
1956                (setq hi (list 'intv (if (memq (nth 1 b) '(1 3)) 3 0) hi hi)))
1957            (math-combine-intervals
1958             (nth 2 lo) (and (or (memq (nth 1 b) '(2 3))
1959                                 (math-infinitep (nth 2 lo)))
1960                             (memq (nth 1 lo) '(2 3)))
1961             (nth 3 lo) (and (or (memq (nth 1 b) '(2 3))
1962                                 (math-infinitep (nth 3 lo)))
1963                             (memq (nth 1 lo) '(1 3)))
1964             (nth 2 hi) (and (or (memq (nth 1 b) '(1 3))
1965                                 (math-infinitep (nth 2 hi)))
1966                             (memq (nth 1 hi) '(2 3)))
1967             (nth 3 hi) (and (or (memq (nth 1 b) '(1 3))
1968                                 (math-infinitep (nth 3 hi)))
1969                             (memq (nth 1 hi) '(1 3))))))
1970         ((and (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)
1971               (equal (nth 2 a) (nth 2 b)))
1972          (math-make-mod (math-pow-mod (nth 1 a) (nth 1 b) (nth 2 a))
1973                         (nth 2 a)))
1974         ((and (eq (car-safe a) 'mod) (Math-anglep b))
1975          (math-make-mod (math-pow-mod (nth 1 a) b (nth 2 a)) (nth 2 a)))
1976         ((and (eq (car-safe b) 'mod) (Math-anglep a))
1977          (math-make-mod (math-pow-mod a (nth 1 b) (nth 2 b)) (nth 2 b)))
1978         ((not (Math-numberp a))
1979          (math-reject-arg a 'numberp))
1980         (t
1981          (math-reject-arg b 'numberp))))
1982
1983 (defun math-quarter-integer (x)
1984   (if (Math-integerp x)
1985       0
1986     (if (math-negp x)
1987         (progn
1988           (setq x (math-quarter-integer (math-neg x)))
1989           (and x (- 4 x)))
1990       (if (eq (car x) 'frac)
1991           (if (eq (nth 2 x) 2)
1992               2
1993             (and (eq (nth 2 x) 4)
1994                  (progn
1995                    (setq x (nth 1 x))
1996                    (% (if (consp x) (nth 1 x) x) 4))))
1997         (if (eq (car x) 'float)
1998             (if (>= (nth 2 x) 0)
1999                 0
2000               (if (= (nth 2 x) -1)
2001                   (progn
2002                     (setq x (nth 1 x))
2003                     (and (= (% (if (consp x) (nth 1 x) x) 10) 5) 2))
2004                 (if (= (nth 2 x) -2)
2005                     (progn
2006                       (setq x (nth 1 x)
2007                             x (% (if (consp x) (nth 1 x) x) 100))
2008                       (if (= x 25) 1
2009                         (if (= x 75) 3)))))))))))
2010
2011 ;;; This assumes A < M and M > 0.
2012 (defun math-pow-mod (a b m)   ; [R R R R]
2013   (if (and (Math-integerp a) (Math-integerp b) (Math-integerp m))
2014       (if (Math-negp b)
2015           (math-div-mod 1 (math-pow-mod a (Math-integer-neg b) m) m)
2016         (if (eq m 1)
2017             0
2018           (math-pow-mod-step a b m)))
2019     (math-mod (math-pow a b) m)))
2020
2021 (defun math-pow-mod-step (a n m)   ; [I I I I]
2022   (math-working "pow" a)
2023   (let ((val (cond
2024               ((eq n 0) 1)
2025               ((eq n 1) a)
2026               (t
2027                (let ((rest (math-pow-mod-step
2028                             (math-imod (math-mul a a) m)
2029                             (math-div2 n)
2030                             m)))
2031                  (if (math-evenp n)
2032                      rest
2033                    (math-mod (math-mul a rest) m)))))))
2034     (math-working "pow" val)
2035     val))
2036
2037
2038 ;;; Compute the minimum of two real numbers.  [R R R] [Public]
2039 (defun math-min (a b)
2040   (if (and (consp a) (eq (car a) 'intv))
2041       (if (and (consp b) (eq (car b) 'intv))
2042           (let ((lo (nth 2 a))
2043                 (lom (memq (nth 1 a) '(2 3)))
2044                 (hi (nth 3 a))
2045                 (him (memq (nth 1 a) '(1 3)))
2046                 res)
2047             (if (= (setq res (math-compare (nth 2 b) lo)) -1)
2048                 (setq lo (nth 2 b) lom (memq (nth 1 b) '(2 3)))
2049               (if (= res 0)
2050                   (setq lom (or lom (memq (nth 1 b) '(2 3))))))
2051             (if (= (setq res (math-compare (nth 3 b) hi)) -1)
2052                 (setq hi (nth 3 b) him (memq (nth 1 b) '(1 3)))
2053               (if (= res 0)
2054                   (setq him (or him (memq (nth 1 b) '(1 3))))))
2055             (math-make-intv (+ (if lom 2 0) (if him 1 0)) lo hi))
2056         (math-min a (list 'intv 3 b b)))
2057     (if (and (consp b) (eq (car b) 'intv))
2058         (math-min (list 'intv 3 a a) b)
2059       (let ((res (math-compare a b)))
2060         (if (= res 1)
2061             b
2062           (if (= res 2)
2063               '(var nan var-nan)
2064             a))))))
2065
2066 (defun calcFunc-min (&optional a &rest b)
2067   (if (not a)
2068       '(var inf var-inf)
2069     (if (not (or (Math-anglep a) (eq (car a) 'date)
2070                  (and (eq (car a) 'intv) (math-intv-constp a))
2071                  (math-infinitep a)))
2072         (math-reject-arg a 'anglep))
2073     (math-min-list a b)))
2074
2075 (defun math-min-list (a b)
2076   (if b
2077       (if (or (Math-anglep (car b)) (eq (car b) 'date)
2078               (and (eq (car (car b)) 'intv) (math-intv-constp (car b)))
2079               (math-infinitep (car b)))
2080           (math-min-list (math-min a (car b)) (cdr b))
2081         (math-reject-arg (car b) 'anglep))
2082     a))
2083
2084 ;;; Compute the maximum of two real numbers.  [R R R] [Public]
2085 (defun math-max (a b)
2086   (if (or (and (consp a) (eq (car a) 'intv))
2087           (and (consp b) (eq (car b) 'intv)))
2088       (math-neg (math-min (math-neg a) (math-neg b)))
2089     (let ((res (math-compare a b)))
2090       (if (= res -1)
2091           b
2092         (if (= res 2)
2093               '(var nan var-nan)
2094           a)))))
2095
2096 (defun calcFunc-max (&optional a &rest b)
2097   (if (not a)
2098       '(neg (var inf var-inf))
2099     (if (not (or (Math-anglep a) (eq (car a) 'date)
2100                  (and (eq (car a) 'intv) (math-intv-constp a))
2101                  (math-infinitep a)))
2102         (math-reject-arg a 'anglep))
2103     (math-max-list a b)))
2104
2105 (defun math-max-list (a b)
2106   (if b
2107       (if (or (Math-anglep (car b)) (eq (car b) 'date)
2108               (and (eq (car (car b)) 'intv) (math-intv-constp (car b)))
2109               (math-infinitep (car b)))
2110           (math-max-list (math-max a (car b)) (cdr b))
2111         (math-reject-arg (car b) 'anglep))
2112     a))
2113
2114
2115 ;;; Compute the absolute value of A.  [O O; r r] [Public]
2116 (defun math-abs (a)
2117   (cond ((Math-negp a)
2118          (math-neg a))
2119         ((Math-anglep a)
2120          a)
2121         ((eq (car a) 'cplx)
2122          (math-hypot (nth 1 a) (nth 2 a)))
2123         ((eq (car a) 'polar)
2124          (nth 1 a))
2125         ((eq (car a) 'vec)
2126          (if (cdr (cdr (cdr a)))
2127              (math-sqrt (calcFunc-abssqr a))
2128            (if (cdr (cdr a))
2129                (math-hypot (nth 1 a) (nth 2 a))
2130              (if (cdr a)
2131                  (math-abs (nth 1 a))
2132                a))))
2133         ((eq (car a) 'sdev)
2134          (list 'sdev (math-abs (nth 1 a)) (nth 2 a)))
2135         ((and (eq (car a) 'intv) (math-intv-constp a))
2136          (if (Math-posp a)
2137              a
2138            (let* ((nlo (math-neg (nth 2 a)))
2139                   (res (math-compare nlo (nth 3 a))))
2140              (cond ((= res 1)
2141                     (math-make-intv (if (memq (nth 1 a) '(0 1)) 2 3) 0 nlo))
2142                    ((= res 0)
2143                     (math-make-intv (if (eq (nth 1 a) 0) 2 3) 0 nlo))
2144                    (t
2145                     (math-make-intv (if (memq (nth 1 a) '(0 2)) 2 3)
2146                                     0 (nth 3 a)))))))
2147         ((math-looks-negp a)
2148          (list 'calcFunc-abs (math-neg a)))
2149         ((let ((signs (math-possible-signs a)))
2150            (or (and (memq signs '(2 4 6)) a)
2151                (and (memq signs '(1 3)) (math-neg a)))))
2152         ((let ((inf (math-infinitep a)))
2153            (and inf
2154                 (if (equal inf '(var nan var-nan))
2155                     inf
2156                   '(var inf var-inf)))))
2157         (t (calc-record-why 'numvecp a)
2158            (list 'calcFunc-abs a))))
2159
2160 (defalias 'calcFunc-abs 'math-abs)
2161
2162 (defun math-float-fancy (a)
2163   (cond ((eq (car a) 'intv)
2164          (cons (car a) (cons (nth 1 a) (mapcar 'math-float (nthcdr 2 a)))))
2165         ((and (memq (car a) '(* /))
2166               (math-numberp (nth 1 a)))
2167          (list (car a) (math-float (nth 1 a))
2168                (list 'calcFunc-float (nth 2 a))))
2169         ((and (eq (car a) '/)
2170               (eq (car (nth 1 a)) '*)
2171               (math-numberp (nth 1 (nth 1 a))))
2172          (list '* (math-float (nth 1 (nth 1 a)))
2173                (list 'calcFunc-float (list '/ (nth 2 (nth 1 a)) (nth 2 a)))))
2174         ((math-infinitep a) a)
2175         ((eq (car a) 'calcFunc-float) a)
2176         ((let ((func (assq (car a) '((calcFunc-floor  . calcFunc-ffloor)
2177                                      (calcFunc-ceil   . calcFunc-fceil)
2178                                      (calcFunc-trunc  . calcFunc-ftrunc)
2179                                      (calcFunc-round  . calcFunc-fround)
2180                                      (calcFunc-rounde . calcFunc-frounde)
2181                                      (calcFunc-roundu . calcFunc-froundu)))))
2182            (and func (cons (cdr func) (cdr a)))))
2183         (t (math-reject-arg a 'objectp))))
2184
2185 (defalias 'calcFunc-float 'math-float)
2186
2187 (defun math-trunc-fancy (a)
2188   (cond ((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a)))
2189         ((eq (car a) 'cplx) (math-trunc (nth 1 a)))
2190         ((eq (car a) 'polar) (math-trunc (math-complex a)))
2191         ((eq (car a) 'hms) (list 'hms (nth 1 a) 0 0))
2192         ((eq (car a) 'date) (list 'date (math-trunc (nth 1 a))))
2193         ((eq (car a) 'mod)
2194          (if (math-messy-integerp (nth 2 a))
2195              (math-trunc (math-make-mod (nth 1 a) (math-trunc (nth 2 a))))
2196            (math-make-mod (math-trunc (nth 1 a)) (nth 2 a))))
2197         ((eq (car a) 'intv)
2198          (math-make-intv (+ (if (and (equal (nth 2 a) '(neg (var inf var-inf)))
2199                                      (memq (nth 1 a) '(0 1)))
2200                                 0 2)
2201                             (if (and (equal (nth 3 a) '(var inf var-inf))
2202                                      (memq (nth 1 a) '(0 2)))
2203                                 0 1))
2204                          (if (and (Math-negp (nth 2 a))
2205                                   (Math-num-integerp (nth 2 a))
2206                                   (memq (nth 1 a) '(0 1)))
2207                              (math-add (math-trunc (nth 2 a)) 1)
2208                            (math-trunc (nth 2 a)))
2209                          (if (and (Math-posp (nth 3 a))
2210                                   (Math-num-integerp (nth 3 a))
2211                                   (memq (nth 1 a) '(0 2)))
2212                              (math-add (math-trunc (nth 3 a)) -1)
2213                            (math-trunc (nth 3 a)))))
2214         ((math-provably-integerp a) a)
2215         ((Math-vectorp a)
2216          (math-map-vec (function (lambda (x) (math-trunc x prec))) a))
2217         ((math-infinitep a)
2218          (if (or (math-posp a) (math-negp a))
2219              a
2220            '(var nan var-nan)))
2221         ((math-to-integer a))
2222         (t (math-reject-arg a 'numberp))))
2223
2224 (defun math-trunc-special (a prec)
2225   (if (Math-messy-integerp prec)
2226       (setq prec (math-trunc prec)))
2227   (or (integerp prec)
2228       (math-reject-arg prec 'fixnump))
2229   (if (and (<= prec 0)
2230            (math-provably-integerp a))
2231       a
2232     (calcFunc-scf (math-trunc (let ((calc-prefer-frac t))
2233                                 (calcFunc-scf a prec)))
2234                   (- prec))))
2235
2236 (defun math-to-integer (a)
2237   (let ((func (assq (car-safe a) '((calcFunc-ffloor  . calcFunc-floor)
2238                                    (calcFunc-fceil   . calcFunc-ceil)
2239                                    (calcFunc-ftrunc  . calcFunc-trunc)
2240                                    (calcFunc-fround  . calcFunc-round)
2241                                    (calcFunc-frounde . calcFunc-rounde)
2242                                    (calcFunc-froundu . calcFunc-roundu)))))
2243     (and func (= (length a) 2)
2244          (cons (cdr func) (cdr a)))))
2245
2246 (defun calcFunc-ftrunc (a &optional prec)
2247   (if (and (Math-messy-integerp a)
2248            (or (not prec) (and (integerp prec)
2249                                (<= prec 0))))
2250       a
2251     (math-float (math-trunc a prec))))
2252
2253 (defun math-floor-fancy (a)
2254   (cond ((math-provably-integerp a) a)
2255         ((eq (car a) 'hms)
2256          (if (or (math-posp a)
2257                  (and (math-zerop (nth 2 a))
2258                       (math-zerop (nth 3 a))))
2259              (math-trunc a)
2260            (math-add (math-trunc a) -1)))
2261         ((eq (car a) 'date) (list 'date (math-floor (nth 1 a))))
2262         ((eq (car a) 'intv)
2263          (math-make-intv (+ (if (and (equal (nth 2 a) '(neg (var inf var-inf)))
2264                                      (memq (nth 1 a) '(0 1)))
2265                                 0 2)
2266                             (if (and (equal (nth 3 a) '(var inf var-inf))
2267                                      (memq (nth 1 a) '(0 2)))
2268                                 0 1))
2269                          (math-floor (nth 2 a))
2270                          (if (and (Math-num-integerp (nth 3 a))
2271                                   (memq (nth 1 a) '(0 2)))
2272                              (math-add (math-floor (nth 3 a)) -1)
2273                            (math-floor (nth 3 a)))))
2274         ((Math-vectorp a)
2275          (math-map-vec (function (lambda (x) (math-floor x prec))) a))
2276         ((math-infinitep a)
2277          (if (or (math-posp a) (math-negp a))
2278              a
2279            '(var nan var-nan)))
2280         ((math-to-integer a))
2281         (t (math-reject-arg a 'anglep))))
2282
2283 (defun math-floor-special (a prec)
2284   (if (Math-messy-integerp prec)
2285       (setq prec (math-trunc prec)))
2286   (or (integerp prec)
2287       (math-reject-arg prec 'fixnump))
2288   (if (and (<= prec 0)
2289            (math-provably-integerp a))
2290       a
2291     (calcFunc-scf (math-floor (let ((calc-prefer-frac t))
2292                                 (calcFunc-scf a prec)))
2293                   (- prec))))
2294
2295 (defun calcFunc-ffloor (a &optional prec)
2296   (if (and (Math-messy-integerp a)
2297            (or (not prec) (and (integerp prec)
2298                                (<= prec 0))))
2299       a
2300     (math-float (math-floor a prec))))
2301
2302 ;;; Coerce A to be an integer (by truncation toward plus infinity).  [I N]
2303 (defun math-ceiling (a &optional prec)   ;  [Public]
2304   (cond (prec
2305          (if (Math-messy-integerp prec)
2306              (setq prec (math-trunc prec)))
2307          (or (integerp prec)
2308              (math-reject-arg prec 'fixnump))
2309          (if (and (<= prec 0)
2310                   (math-provably-integerp a))
2311              a
2312            (calcFunc-scf (math-ceiling (let ((calc-prefer-frac t))
2313                                          (calcFunc-scf a prec)))
2314                          (- prec))))
2315         ((Math-integerp a) a)
2316         ((Math-messy-integerp a) (math-trunc a))
2317         ((Math-realp a)
2318          (if (Math-posp a)
2319              (math-add (math-trunc a) 1)
2320            (math-trunc a)))
2321         ((math-provably-integerp a) a)
2322         ((eq (car a) 'hms)
2323          (if (or (math-negp a)
2324                  (and (math-zerop (nth 2 a))
2325                       (math-zerop (nth 3 a))))
2326              (math-trunc a)
2327            (math-add (math-trunc a) 1)))
2328         ((eq (car a) 'date) (list 'date (math-ceiling (nth 1 a))))
2329         ((eq (car a) 'intv)
2330          (math-make-intv (+ (if (and (equal (nth 2 a) '(neg (var inf var-inf)))
2331                                      (memq (nth 1 a) '(0 1)))
2332                                 0 2)
2333                             (if (and (equal (nth 3 a) '(var inf var-inf))
2334                                      (memq (nth 1 a) '(0 2)))
2335                                 0 1))
2336                          (if (and (Math-num-integerp (nth 2 a))
2337                                   (memq (nth 1 a) '(0 1)))
2338                              (math-add (math-floor (nth 2 a)) 1)
2339                            (math-ceiling (nth 2 a)))
2340                          (math-ceiling (nth 3 a))))
2341         ((Math-vectorp a)
2342          (math-map-vec (function (lambda (x) (math-ceiling x prec))) a))
2343         ((math-infinitep a)
2344          (if (or (math-posp a) (math-negp a))
2345              a
2346            '(var nan var-nan)))
2347         ((math-to-integer a))
2348         (t (math-reject-arg a 'anglep))))
2349
2350 (defalias 'calcFunc-ceil 'math-ceiling)
2351
2352 (defun calcFunc-fceil (a &optional prec)
2353   (if (and (Math-messy-integerp a)
2354            (or (not prec) (and (integerp prec)
2355                                (<= prec 0))))
2356       a
2357     (math-float (math-ceiling a prec))))
2358
2359 (defvar math-rounding-mode nil)
2360
2361 ;;; Coerce A to be an integer (by rounding to nearest integer).  [I N] [Public]
2362 (defun math-round (a &optional prec)
2363   (cond (prec
2364          (if (Math-messy-integerp prec)
2365              (setq prec (math-trunc prec)))
2366          (or (integerp prec)
2367              (math-reject-arg prec 'fixnump))
2368          (if (and (<= prec 0)
2369                   (math-provably-integerp a))
2370              a
2371            (calcFunc-scf (math-round (let ((calc-prefer-frac t))
2372                                        (calcFunc-scf a prec)))
2373                          (- prec))))
2374         ((Math-anglep a)
2375          (if (Math-num-integerp a)
2376              (math-trunc a)
2377            (if (and (Math-negp a) (not (eq math-rounding-mode 'up)))
2378                (math-neg (math-round (math-neg a)))
2379              (setq a (let ((calc-angle-mode 'deg))   ; in case of HMS forms
2380                        (math-add a (if (Math-ratp a)
2381                                        '(frac 1 2)
2382                                      '(float 5 -1)))))
2383              (if (and (Math-num-integerp a) (eq math-rounding-mode 'even))
2384                  (progn
2385                    (setq a (math-floor a))
2386                    (or (math-evenp a)
2387                        (setq a (math-sub a 1)))
2388                    a)
2389                (math-floor a)))))
2390         ((math-provably-integerp a) a)
2391         ((eq (car a) 'date) (list 'date (math-round (nth 1 a))))
2392         ((eq (car a) 'intv)
2393          (math-floor (math-add a '(frac 1 2))))
2394         ((Math-vectorp a)
2395          (math-map-vec (function (lambda (x) (math-round x prec))) a))
2396         ((math-infinitep a)
2397          (if (or (math-posp a) (math-negp a))
2398              a
2399            '(var nan var-nan)))
2400         ((math-to-integer a))
2401         (t (math-reject-arg a 'anglep))))
2402
2403 (defalias 'calcFunc-round 'math-round)
2404
2405 (defsubst calcFunc-rounde (a &optional prec)
2406   (let ((math-rounding-mode 'even))
2407     (math-round a prec)))
2408
2409 (defsubst calcFunc-roundu (a &optional prec)
2410   (let ((math-rounding-mode 'up))
2411     (math-round a prec)))
2412
2413 (defun calcFunc-fround (a &optional prec)
2414   (if (and (Math-messy-integerp a)
2415            (or (not prec) (and (integerp prec)
2416                                (<= prec 0))))
2417       a
2418     (math-float (math-round a prec))))
2419
2420 (defsubst calcFunc-frounde (a &optional prec)
2421   (let ((math-rounding-mode 'even))
2422     (calcFunc-fround a prec)))
2423
2424 (defsubst calcFunc-froundu (a &optional prec)
2425   (let ((math-rounding-mode 'up))
2426     (calcFunc-fround a prec)))
2427
2428 ;;; Pull floating-point values apart into mantissa and exponent.
2429 (defun calcFunc-mant (x)
2430   (if (Math-realp x)
2431       (if (or (Math-ratp x)
2432               (eq (nth 1 x) 0))
2433           x
2434         (list 'float (nth 1 x) (- 1 (math-numdigs (nth 1 x)))))
2435     (calc-record-why 'realp x)
2436     (list 'calcFunc-mant x)))
2437
2438 (defun calcFunc-xpon (x)
2439   (if (Math-realp x)
2440       (if (or (Math-ratp x)
2441               (eq (nth 1 x) 0))
2442           0
2443         (math-normalize (+ (nth 2 x) (1- (math-numdigs (nth 1 x))))))
2444     (calc-record-why 'realp x)
2445     (list 'calcFunc-xpon x)))
2446
2447 (defun calcFunc-scf (x n)
2448   (if (integerp n)
2449       (cond ((eq n 0)
2450              x)
2451             ((Math-integerp x)
2452              (if (> n 0)
2453                  (math-scale-int x n)
2454                (math-div x (math-scale-int 1 (- n)))))
2455             ((eq (car x) 'frac)
2456              (if (> n 0)
2457                  (math-make-frac (math-scale-int (nth 1 x) n) (nth 2 x))
2458                (math-make-frac (nth 1 x) (math-scale-int (nth 2 x) (- n)))))
2459             ((eq (car x) 'float)
2460              (math-make-float (nth 1 x) (+ (nth 2 x) n)))
2461             ((memq (car x) '(cplx sdev))
2462              (math-normalize
2463               (list (car x)
2464                     (calcFunc-scf (nth 1 x) n)
2465                     (calcFunc-scf (nth 2 x) n))))
2466             ((memq (car x) '(polar mod))
2467              (math-normalize
2468               (list (car x)
2469                     (calcFunc-scf (nth 1 x) n)
2470                     (nth 2 x))))
2471             ((eq (car x) 'intv)
2472              (math-normalize
2473               (list (car x)
2474                     (nth 1 x)
2475                     (calcFunc-scf (nth 2 x) n)
2476                     (calcFunc-scf (nth 3 x) n))))
2477             ((eq (car x) 'vec)
2478              (math-map-vec (function (lambda (x) (calcFunc-scf x n))) x))
2479             ((math-infinitep x)
2480              x)
2481             (t
2482              (calc-record-why 'realp x)
2483              (list 'calcFunc-scf x n)))
2484     (if (math-messy-integerp n)
2485         (if (< (nth 2 n) 10)
2486             (calcFunc-scf x (math-trunc n))
2487           (math-overflow n))
2488       (if (math-integerp n)
2489           (math-overflow n)
2490         (calc-record-why 'integerp n)
2491         (list 'calcFunc-scf x n)))))
2492
2493
2494 (defun calcFunc-incr (x &optional step relative-to)
2495   (or step (setq step 1))
2496   (cond ((not (Math-integerp step))
2497          (math-reject-arg step 'integerp))
2498         ((Math-integerp x)
2499          (math-add x step))
2500         ((eq (car x) 'float)
2501          (if (and (math-zerop x)
2502                   (eq (car-safe relative-to) 'float))
2503              (math-mul step
2504                        (calcFunc-scf relative-to (- 1 calc-internal-prec)))
2505            (math-add-float x (math-make-float
2506                               step
2507                               (+ (nth 2 x)
2508                                  (- (math-numdigs (nth 1 x))
2509                                     calc-internal-prec))))))
2510         ((eq (car x) 'date)
2511          (if (Math-integerp (nth 1 x))
2512              (math-add x step)
2513            (math-add x (list 'hms 0 0 step))))
2514         (t
2515          (math-reject-arg x 'realp))))
2516
2517 (defsubst calcFunc-decr (x &optional step relative-to)
2518   (calcFunc-incr x (math-neg (or step 1)) relative-to))
2519
2520 (defun calcFunc-percent (x)
2521   (if (math-objectp x)
2522       (let ((calc-prefer-frac nil))
2523         (math-div x 100))
2524     (list 'calcFunc-percent x)))
2525
2526 (defun calcFunc-relch (x y)
2527   (if (and (math-objectp x) (math-objectp y))
2528       (math-div (math-sub y x) x)
2529     (list 'calcFunc-relch x y)))
2530
2531 ;;; Compute the absolute value squared of A.  [F N] [Public]
2532 (defun calcFunc-abssqr (a)
2533   (cond ((Math-realp a)
2534          (math-mul a a))
2535         ((eq (car a) 'cplx)
2536          (math-add (math-sqr (nth 1 a))
2537                    (math-sqr (nth 2 a))))
2538         ((eq (car a) 'polar)
2539          (math-sqr (nth 1 a)))
2540         ((and (memq (car a) '(sdev intv)) (math-constp a))
2541          (math-sqr (math-abs a)))
2542         ((eq (car a) 'vec)
2543          (math-reduce-vec 'math-add (math-map-vec 'calcFunc-abssqr a)))
2544         ((math-known-realp a)
2545          (math-pow a 2))
2546         ((let ((inf (math-infinitep a)))
2547            (and inf
2548                 (math-mul (calcFunc-abssqr (math-infinite-dir a inf)) inf))))
2549         (t (calc-record-why 'numvecp a)
2550            (list 'calcFunc-abssqr a))))
2551
2552 (defsubst math-sqr (a)
2553   (math-mul a a))
2554
2555 ;;;; Number theory.
2556
2557 (defun calcFunc-idiv (a b)   ; [I I I] [Public]
2558   (cond ((and (Math-natnump a) (Math-natnump b) (not (eq b 0)))
2559          (math-quotient a b))
2560         ((Math-realp a)
2561          (if (Math-realp b)
2562              (let ((calc-prefer-frac t))
2563                (math-floor (math-div a b)))
2564            (math-reject-arg b 'realp)))
2565         ((eq (car-safe a) 'hms)
2566          (if (eq (car-safe b) 'hms)
2567              (let ((calc-prefer-frac t))
2568                (math-floor (math-div a b)))
2569            (math-reject-arg b 'hmsp)))
2570         ((and (or (eq (car-safe a) 'intv) (Math-realp a))
2571               (or (eq (car-safe b) 'intv) (Math-realp b)))
2572          (math-floor (math-div a b)))
2573         ((or (math-infinitep a)
2574              (math-infinitep b))
2575          (math-div a b))
2576         (t (math-reject-arg a 'anglep))))
2577
2578
2579 ;;; Combine two terms being added, if possible.
2580 (defun math-combine-sum (a b nega negb scalar-okay)
2581   (if (and scalar-okay (Math-objvecp a) (Math-objvecp b))
2582       (math-add-or-sub a b nega negb)
2583     (let ((amult 1) (bmult 1))
2584       (and (consp a)
2585            (cond ((and (eq (car a) '*)
2586                        (Math-objectp (nth 1 a)))
2587                   (setq amult (nth 1 a)
2588                         a (nth 2 a)))
2589                  ((and (eq (car a) '/)
2590                        (Math-objectp (nth 2 a)))
2591                   (setq amult (if (Math-integerp (nth 2 a))
2592                                   (list 'frac 1 (nth 2 a))
2593                                 (math-div 1 (nth 2 a)))
2594                         a (nth 1 a)))
2595                  ((eq (car a) 'neg)
2596                   (setq amult -1
2597                         a (nth 1 a)))))
2598       (and (consp b)
2599            (cond ((and (eq (car b) '*)
2600                        (Math-objectp (nth 1 b)))
2601                   (setq bmult (nth 1 b)
2602                         b (nth 2 b)))
2603                  ((and (eq (car b) '/)
2604                        (Math-objectp (nth 2 b)))
2605                   (setq bmult (if (Math-integerp (nth 2 b))
2606                                   (list 'frac 1 (nth 2 b))
2607                                 (math-div 1 (nth 2 b)))
2608                         b (nth 1 b)))
2609                  ((eq (car b) 'neg)
2610                   (setq bmult -1
2611                         b (nth 1 b)))))
2612       (and (if math-simplifying
2613                (Math-equal a b)
2614              (equal a b))
2615            (progn
2616              (if nega (setq amult (math-neg amult)))
2617              (if negb (setq bmult (math-neg bmult)))
2618              (setq amult (math-add amult bmult))
2619              (math-mul amult a))))))
2620
2621 (defun math-add-or-sub (a b aneg bneg)
2622   (if aneg (setq a (math-neg a)))
2623   (if bneg (setq b (math-neg b)))
2624   (if (or (Math-vectorp a) (Math-vectorp b))
2625       (math-normalize (list '+ a b))
2626     (math-add a b)))
2627
2628 (defvar math-combine-prod-e '(var e var-e))
2629
2630 ;;; The following is expanded out four ways for speed.
2631 (defun math-combine-prod (a b inva invb scalar-okay)
2632   (cond
2633    ((or (and inva (Math-zerop a))
2634         (and invb (Math-zerop b)))
2635     nil)
2636    ((and scalar-okay (Math-objvecp a) (Math-objvecp b))
2637     (setq a (math-mul-or-div a b inva invb))
2638     (and (Math-objvecp a)
2639          a))
2640    ((and (eq (car-safe a) '^)
2641          inva
2642          (math-looks-negp (nth 2 a)))
2643     (math-mul (math-pow (nth 1 a) (math-neg (nth 2 a))) b))
2644    ((and (eq (car-safe b) '^)
2645          invb
2646          (math-looks-negp (nth 2 b)))
2647     (math-mul a (math-pow (nth 1 b) (math-neg (nth 2 b)))))
2648    (t (let ((apow 1) (bpow 1))
2649         (and (consp a)
2650              (cond ((and (eq (car a) '^)
2651                          (or math-simplifying
2652                              (Math-numberp (nth 2 a))))
2653                     (setq apow (nth 2 a)
2654                           a (nth 1 a)))
2655                    ((eq (car a) 'calcFunc-sqrt)
2656                     (setq apow '(frac 1 2)
2657                           a (nth 1 a)))
2658                    ((and (eq (car a) 'calcFunc-exp)
2659                          (or math-simplifying
2660                              (Math-numberp (nth 1 a))))
2661                     (setq apow (nth 1 a)
2662                           a math-combine-prod-e))))
2663         (and (consp a) (eq (car a) 'frac)
2664              (Math-lessp (nth 1 a) (nth 2 a))
2665              (setq a (math-div 1 a) apow (math-neg apow)))
2666         (and (consp b)
2667              (cond ((and (eq (car b) '^)
2668                          (or math-simplifying
2669                              (Math-numberp (nth 2 b))))
2670                     (setq bpow (nth 2 b)
2671                           b (nth 1 b)))
2672                    ((eq (car b) 'calcFunc-sqrt)
2673                     (setq bpow '(frac 1 2)
2674                           b (nth 1 b)))
2675                    ((and (eq (car b) 'calcFunc-exp)
2676                          (or math-simplifying
2677                              (Math-numberp (nth 1 b))))
2678                     (setq bpow (nth 1 b)
2679                           b math-combine-prod-e))))
2680         (and (consp b) (eq (car b) 'frac)
2681              (Math-lessp (nth 1 b) (nth 2 b))
2682              (setq b (math-div 1 b) bpow (math-neg bpow)))
2683         (if inva (setq apow (math-neg apow)))
2684         (if invb (setq bpow (math-neg bpow)))
2685         (or (and (if math-simplifying
2686                      (math-commutative-equal a b)
2687                    (equal a b))
2688                  (let ((sumpow (math-add apow bpow)))
2689                    (and (or (not (Math-integerp a))
2690                             (Math-zerop sumpow)
2691                             (eq (eq (car-safe apow) 'frac)
2692                                 (eq (car-safe bpow) 'frac)))
2693                         (progn
2694                           (and (math-looks-negp sumpow)
2695                                (Math-ratp a) (Math-posp a)
2696                                (setq a (math-div 1 a)
2697                                      sumpow (math-neg sumpow)))
2698                           (cond ((equal sumpow '(frac 1 2))
2699                                  (list 'calcFunc-sqrt a))
2700                                 ((equal sumpow '(frac -1 2))
2701                                  (math-div 1 (list 'calcFunc-sqrt a)))
2702                                 ((and (eq a math-combine-prod-e)
2703                                       (eq a b))
2704                                  (list 'calcFunc-exp sumpow))
2705                                 (t
2706                                  (condition-case err
2707                                      (math-pow a sumpow)
2708                                    (inexact-result (list '^ a sumpow)))))))))
2709             (and math-simplifying-units
2710                  math-combining-units
2711                  (let* ((ua (math-check-unit-name a))
2712                         ub)
2713                    (and ua
2714                         (eq ua (setq ub (math-check-unit-name b)))
2715                         (progn
2716                           (setq ua (if (eq (nth 1 a) (car ua))
2717                                        1
2718                                      (nth 1 (assq (aref (symbol-name (nth 1 a))
2719                                                         0)
2720                                                   math-unit-prefixes)))
2721                                 ub (if (eq (nth 1 b) (car ub))
2722                                        1
2723                                      (nth 1 (assq (aref (symbol-name (nth 1 b))
2724                                                         0)
2725                                                   math-unit-prefixes))))
2726                           (if (Math-lessp ua ub)
2727                               (let (temp)
2728                                 (setq temp a a b b temp
2729                                       temp ua ua ub ub temp
2730                                       temp apow apow bpow bpow temp)))
2731                           (math-mul (math-pow (math-div ua ub) apow)
2732                                     (math-pow b (math-add apow bpow)))))))
2733             (and (equal apow bpow)
2734                  (Math-natnump a) (Math-natnump b)
2735                  (cond ((equal apow '(frac 1 2))
2736                         (list 'calcFunc-sqrt (math-mul a b)))
2737                        ((equal apow '(frac -1 2))
2738                         (math-div 1 (list 'calcFunc-sqrt (math-mul a b))))
2739                        (t
2740                         (setq a (math-mul a b))
2741                         (condition-case err
2742                             (math-pow a apow)
2743                           (inexact-result (list '^ a apow)))))))))))
2744
2745 (defun math-mul-or-div (a b ainv binv)
2746   (if (or (Math-vectorp a) (Math-vectorp b))
2747       (math-normalize
2748        (if ainv
2749            (if binv
2750                (list '/ (math-div 1 a) b)
2751              (list '/ b a))
2752          (if binv
2753              (list '/ a b)
2754            (list '* a b))))
2755     (if ainv
2756         (if binv
2757             (math-div (math-div 1 a) b)
2758           (math-div b a))
2759       (if binv
2760           (math-div a b)
2761         (math-mul a b)))))
2762
2763 (defun math-commutative-equal (a b)
2764   (if (memq (car-safe a) '(+ -))
2765       (and (memq (car-safe b) '(+ -))
2766            (let ((bterms nil) aterms p)
2767              (math-commutative-collect b nil)
2768              (setq aterms bterms bterms nil)
2769              (math-commutative-collect a nil)
2770              (and (= (length aterms) (length bterms))
2771                   (progn
2772                     (while (and aterms
2773                                 (progn
2774                                   (setq p bterms)
2775                                   (while (and p (not (equal (car aterms)
2776                                                             (car p))))
2777                                     (setq p (cdr p)))
2778                                   p))
2779                       (setq bterms (delq (car p) bterms)
2780                             aterms (cdr aterms)))
2781                     (not aterms)))))
2782     (equal a b)))
2783
2784 (defun math-commutative-collect (b neg)
2785   (if (eq (car-safe b) '+)
2786       (progn
2787         (math-commutative-collect (nth 1 b) neg)
2788         (math-commutative-collect (nth 2 b) neg))
2789     (if (eq (car-safe b) '-)
2790         (progn
2791           (math-commutative-collect (nth 1 b) neg)
2792           (math-commutative-collect (nth 2 b) (not neg)))
2793       (setq bterms (cons (if neg (math-neg b) b) bterms)))))
2794
2795 ;;; calc-arith.el ends here