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