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