1 ;;; calc-arith.el --- arithmetic functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
6 ;; Author: David Gillespie <daveg@synaptics.com>
7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 3, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
30 ;; This file is autoloaded from calc-ext.el.
35 ;;; The following lists are not exhaustive.
36 (defvar math-scalar-functions
'(calcFunc-det
37 calcFunc-cnorm calcFunc-rnorm
38 calcFunc-vlen calcFunc-vcount
39 calcFunc-vsum calcFunc-vprod
40 calcFunc-vmin calcFunc-vmax
))
42 (defvar math-nonscalar-functions
'(vec calcFunc-idn calcFunc-diag
43 calcFunc-cvec calcFunc-index
46 calcFunc-cons calcFunc-rcons
47 calcFunc-tail calcFunc-rhead
))
49 (defvar math-scalar-if-args-functions
'(+ -
* / neg
))
51 (defvar math-real-functions
'(calcFunc-arg
52 calcFunc-re calcFunc-im
53 calcFunc-floor calcFunc-ceil
54 calcFunc-trunc calcFunc-round
55 calcFunc-rounde calcFunc-roundu
56 calcFunc-ffloor calcFunc-fceil
57 calcFunc-ftrunc calcFunc-fround
58 calcFunc-frounde calcFunc-froundu
))
60 (defvar math-positive-functions
'())
62 (defvar math-nonnegative-functions
'(calcFunc-cnorm calcFunc-rnorm
63 calcFunc-vlen calcFunc-vcount
))
65 (defvar math-real-scalar-functions
'(% calcFunc-idiv calcFunc-abs
66 calcFunc-choose calcFunc-perm
67 calcFunc-eq calcFunc-neq
68 calcFunc-lt calcFunc-gt
69 calcFunc-leq calcFunc-geq
71 calcFunc-max calcFunc-min
))
73 (defvar math-real-if-arg-functions
'(calcFunc-sin calcFunc-cos
74 calcFunc-tan calcFunc-sec
75 calcFunc-csc calcFunc-cot
77 calcFunc-sinh calcFunc-cosh
78 calcFunc-tanh calcFunc-sech
79 calcFunc-csch calcFunc-coth
81 calcFunc-gamma calcFunc-fact
))
83 (defvar math-integer-functions
'(calcFunc-idiv
84 calcFunc-isqrt calcFunc-ilog
85 calcFunc-vlen calcFunc-vcount
))
87 (defvar math-num-integer-functions
'())
89 (defvar math-rounding-functions
'(calcFunc-floor
91 calcFunc-round calcFunc-trunc
92 calcFunc-rounde calcFunc-roundu
))
94 (defvar math-float-rounding-functions
'(calcFunc-ffloor
96 calcFunc-fround calcFunc-ftrunc
97 calcFunc-frounde calcFunc-froundu
))
99 (defvar math-integer-if-args-functions
'(+ -
* % neg calcFunc-abs
100 calcFunc-min calcFunc-max
101 calcFunc-choose calcFunc-perm
))
106 (defun calc-min (arg)
109 (calc-binary-op "min" 'calcFunc-min arg
'(var inf var-inf
))))
111 (defun calc-max (arg)
114 (calc-binary-op "max" 'calcFunc-max arg
'(neg (var inf var-inf
)))))
116 (defun calc-abs (arg)
119 (calc-unary-op "abs" 'calcFunc-abs arg
)))
122 (defun calc-idiv (arg)
125 (calc-binary-op "\\" 'calcFunc-idiv arg
1)))
128 (defun calc-floor (arg)
131 (if (calc-is-inverse)
132 (if (calc-is-hyperbolic)
133 (calc-unary-op "ceil" 'calcFunc-fceil arg
)
134 (calc-unary-op "ceil" 'calcFunc-ceil arg
))
135 (if (calc-is-hyperbolic)
136 (calc-unary-op "flor" 'calcFunc-ffloor arg
)
137 (calc-unary-op "flor" 'calcFunc-floor arg
)))))
139 (defun calc-ceiling (arg)
144 (defun calc-round (arg)
147 (if (calc-is-inverse)
148 (if (calc-is-hyperbolic)
149 (calc-unary-op "trnc" 'calcFunc-ftrunc arg
)
150 (calc-unary-op "trnc" 'calcFunc-trunc arg
))
151 (if (calc-is-hyperbolic)
152 (calc-unary-op "rond" 'calcFunc-fround arg
)
153 (calc-unary-op "rond" 'calcFunc-round arg
)))))
155 (defun calc-trunc (arg)
160 (defun calc-mant-part (arg)
163 (calc-unary-op "mant" 'calcFunc-mant arg
)))
165 (defun calc-xpon-part (arg)
168 (calc-unary-op "xpon" 'calcFunc-xpon arg
)))
170 (defun calc-scale-float (arg)
173 (calc-binary-op "scal" 'calcFunc-scf arg
)))
175 (defun calc-abssqr (arg)
178 (calc-unary-op "absq" 'calcFunc-abssqr arg
)))
180 (defun calc-sign (arg)
183 (calc-unary-op "sign" 'calcFunc-sign arg
)))
185 (defun calc-increment (arg)
188 (calc-enter-result 1 "incr" (list 'calcFunc-incr
(calc-top-n 1) arg
))))
190 (defun calc-decrement (arg)
193 (calc-enter-result 1 "decr" (list 'calcFunc-decr
(calc-top-n 1) arg
))))
196 (defun math-abs-approx (a)
202 (math-add (math-abs (nth 1 a
)) (math-abs (nth 2 a
))))
206 (math-abs-approx (nth 1 a
)))
208 (math-max (math-abs (nth 2 a
)) (math-abs (nth 3 a
))))
212 (math-reduce-vec 'math-add-abs-approx a
))
213 ((eq (car a
) 'calcFunc-abs
)
217 (defun math-add-abs-approx (a b
)
218 (math-add (math-abs-approx a
) (math-abs-approx b
)))
223 (defvar math-decls-cache-tag nil
)
224 (defvar math-decls-cache nil
)
225 (defvar math-decls-all nil
)
227 ;;; Math-decls-cache is an a-list where each entry is a list of the form:
228 ;;; (VAR TYPES RANGE)
229 ;;; where VAR is a variable name (with var- prefix) or function name;
230 ;;; TYPES is a list of type symbols (any, int, frac, ...)
231 ;;; RANGE is a sorted vector of intervals describing the range.
233 (defvar math-super-types
234 '((int numint rat real number
)
236 (frac rat real number
)
242 (sqmatrix matrix vector
)
247 (defun math-setup-declarations ()
248 (or (eq math-decls-cache-tag
(calc-var-value 'var-Decls
))
249 (let ((p (calc-var-value 'var-Decls
))
251 (setq math-decls-cache-tag p
252 math-decls-cache nil
)
253 (and (eq (car-safe p
) 'vec
)
254 (while (setq p
(cdr p
))
255 (and (eq (car-safe (car p
)) 'vec
)
256 (setq vec
(nth 2 (car p
)))
258 (let ((v (nth 1 (car p
))))
259 (setq type nil range nil
)
260 (or (eq (car-safe vec
) 'vec
)
261 (setq vec
(list 'vec vec
)))
262 (while (and (setq vec
(cdr vec
))
263 (not (Math-objectp (car vec
))))
264 (and (eq (car-safe (car vec
)) 'var
)
265 (let ((st (assq (nth 1 (car vec
))
267 (cond (st (setq type
(append type st
)))
268 ((eq (nth 1 (car vec
)) 'pos
)
269 (setq type
(append type
272 '(intv 1 0 (var inf var-inf
))))
273 ((eq (nth 1 (car vec
)) 'nonneg
)
274 (setq type
(append type
278 (var inf var-inf
))))))))
280 (setq type
(append type
'(real number
))
281 range
(math-prepare-set (cons 'vec vec
))))
282 (setq type
(list type range
))
283 (or (eq (car-safe v
) 'vec
)
284 (setq v
(list 'vec v
)))
285 (while (setq v
(cdr v
))
286 (if (or (eq (car-safe (car v
)) 'var
)
287 (not (Math-primp (car v
))))
288 (setq math-decls-cache
289 (cons (cons (if (eq (car (car v
)) 'var
)
293 math-decls-cache
)))))
295 (setq math-decls-all
(assq 'var-All math-decls-cache
)))))
297 (defun math-known-scalarp (a &optional assume-scalar
)
298 (math-setup-declarations)
299 (if (if calc-matrix-mode
300 (eq calc-matrix-mode
'scalar
)
302 (not (math-check-known-matrixp a
))
303 (math-check-known-scalarp a
)))
305 (defun math-known-matrixp (a)
306 (and (not (Math-scalarp a
))
307 (not (math-known-scalarp a t
))))
309 (defun math-known-square-matrixp (a)
310 (and (math-known-matrixp a
)
311 (math-check-known-square-matrixp a
)))
313 ;;; Try to prove that A is a scalar (i.e., a non-vector).
314 (defun math-check-known-scalarp (a)
315 (cond ((Math-objectp a
) t
)
316 ((memq (car a
) math-scalar-functions
)
318 ((memq (car a
) math-real-scalar-functions
)
320 ((memq (car a
) math-scalar-if-args-functions
)
321 (while (and (setq a
(cdr a
))
322 (math-check-known-scalarp (car a
))))
325 (math-check-known-scalarp (nth 1 a
)))
326 ((math-const-var a
) t
)
328 (let ((decl (if (eq (car a
) 'var
)
329 (or (assq (nth 2 a
) math-decls-cache
)
331 (assq (car a
) math-decls-cache
)))
334 ((memq 'scalar
(nth 1 decl
))
336 ((and (eq (car a
) 'var
)
339 (setq val
(symbol-value (nth 2 a
))))
340 (math-check-known-scalarp val
))
344 ;;; Try to prove that A is *not* a scalar.
345 (defun math-check-known-matrixp (a)
346 (cond ((Math-objectp a
) nil
)
347 ((memq (car a
) math-nonscalar-functions
)
349 ((memq (car a
) math-scalar-if-args-functions
)
350 (while (and (setq a
(cdr a
))
351 (not (math-check-known-matrixp (car a
)))))
354 (math-check-known-matrixp (nth 1 a
)))
355 ((math-const-var a
) nil
)
357 (let ((decl (if (eq (car a
) 'var
)
358 (or (assq (nth 2 a
) math-decls-cache
)
360 (assq (car a
) math-decls-cache
)))
363 ((memq 'matrix
(nth 1 decl
))
365 ((and (eq (car a
) 'var
)
368 (setq val
(symbol-value (nth 2 a
))))
369 (math-check-known-matrixp val
))
373 ;;; Given that A is a matrix, try to prove that it is a square matrix.
374 (defun math-check-known-square-matrixp (a)
375 (cond ((math-square-matrixp a
)
377 ((eq (car-safe a
) '^
)
378 (math-check-known-square-matrixp (nth 1 a
)))
382 (eq (car-safe a
) '-
))
384 (math-check-known-square-matrixp (nth 1 a
))
385 (math-check-known-square-matrixp (nth 2 a
))))
387 (let ((decl (if (eq (car a
) 'var
)
388 (or (assq (nth 2 a
) math-decls-cache
)
390 (assq (car a
) math-decls-cache
)))
393 ((memq 'sqmatrix
(nth 1 decl
))
395 ((and (eq (car a
) 'var
)
397 (setq val
(symbol-value (nth 2 a
))))
398 (math-check-known-square-matrixp val
))
400 (integerp calc-matrix-mode
)
401 (eq calc-matrix-mode
'sqmatrix
))
402 (eq (car-safe a
) 'var
))
404 ((memq 'matrix
(nth 1 decl
))
409 ;;; Try to prove that A is a real (i.e., not complex).
410 (defun math-known-realp (a)
411 (< (math-possible-signs a
) 8))
413 ;;; Try to prove that A is real and positive.
414 (defun math-known-posp (a)
415 (eq (math-possible-signs a
) 4))
417 ;;; Try to prove that A is real and negative.
418 (defun math-known-negp (a)
419 (eq (math-possible-signs a
) 1))
421 ;;; Try to prove that A is real and nonnegative.
422 (defun math-known-nonnegp (a)
423 (memq (math-possible-signs a
) '(2 4 6)))
425 ;;; Try to prove that A is real and nonpositive.
426 (defun math-known-nonposp (a)
427 (memq (math-possible-signs a
) '(1 2 3)))
429 ;;; Try to prove that A is nonzero.
430 (defun math-known-nonzerop (a)
431 (memq (math-possible-signs a
) '(1 4 5 8 9 12 13)))
433 ;;; Return true if A is negative, or looks negative but we don't know.
434 (defun math-guess-if-neg (a)
435 (let ((sgn (math-possible-signs a
)))
436 (if (memq sgn
'(1 3))
438 (if (memq sgn
'(2 4 6))
440 (math-looks-negp a
)))))
442 ;;; Find the possible signs of A, assuming A is a number of some kind.
443 ;;; Returns an integer with bits: 1 may be negative,
445 ;;; 4 may be positive,
446 ;;; 8 may be nonreal.
448 (defun math-possible-signs (a &optional origin
)
449 (cond ((Math-objectp a
)
450 (if origin
(setq a
(math-sub a origin
)))
451 (cond ((Math-posp a
) 4)
456 ((math-known-posp (nth 2 a
)) 4)
457 ((math-known-negp (nth 3 a
)) 1)
458 ((Math-zerop (nth 2 a
)) 6)
459 ((Math-zerop (nth 3 a
)) 3)
462 (if (math-known-realp (nth 1 a
)) 7 15))
464 ((memq (car a
) '(+ -
))
465 (cond ((Math-realp (nth 1 a
))
468 (math-possible-signs (nth 2 a
)
470 (math-add origin
(nth 1 a
))
472 (math-possible-signs (nth 2 a
)
474 (math-sub origin
(nth 1 a
))
475 (math-neg (nth 1 a
))))))
476 ((Math-realp (nth 2 a
))
477 (let ((org (if (eq (car a
) '-
)
479 (math-neg (nth 2 a
)))))
480 (math-possible-signs (nth 1 a
)
482 (math-add origin org
)
485 (let ((s1 (math-possible-signs (nth 1 a
) origin
))
486 (s2 (math-possible-signs (nth 2 a
))))
487 (if (eq (car a
) '-
) (setq s2
(math-neg-signs s2
)))
488 (cond ((eq s1 s2
) s1
)
493 ((and (eq s1
4) (eq s2
6)) 4)
494 ((and (eq s2
4) (eq s1
6)) 4)
495 ((and (eq s1
1) (eq s2
3)) 1)
496 ((and (eq s2
1) (eq s1
3)) 1)
499 (math-neg-signs (math-possible-signs
501 (and origin
(math-neg origin
)))))
502 ((and origin
(Math-zerop origin
) (setq origin nil
)
504 ((and (or (eq (car a
) '*)
505 (and (eq (car a
) '/) origin
))
506 (Math-realp (nth 1 a
)))
507 (let ((s (if (eq (car a
) '*)
508 (if (Math-zerop (nth 1 a
))
509 (math-possible-signs 0 origin
)
510 (math-possible-signs (nth 2 a
)
511 (math-div (or origin
0)
514 (math-possible-signs (nth 2 a
)
517 (if (Math-negp (nth 1 a
)) (math-neg-signs s
) s
)))
518 ((and (memq (car a
) '(* /)) (Math-realp (nth 2 a
)))
519 (let ((s (math-possible-signs (nth 1 a
)
521 (math-mul (or origin
0) (nth 2 a
))
522 (math-div (or origin
0) (nth 2 a
))))))
523 (if (Math-negp (nth 2 a
)) (math-neg-signs s
) s
)))
526 (while (and (setq a
(cdr a
)) (< signs
15))
527 (setq signs
(logior signs
(math-possible-signs
532 ((memq (car a
) '(* /))
533 (let ((s1 (math-possible-signs (nth 1 a
)))
534 (s2 (math-possible-signs (nth 2 a
))))
537 ((and (eq (car a
) '/) (memq s2
'(2 3 6 7))) 15)
539 (logior (if (memq s1
'(4 5 6 7)) s2
0)
540 (if (memq s1
'(2 3 6 7)) 2 0)
541 (if (memq s1
'(1 3 5 7))
542 (math-neg-signs s2
) 0))))))
544 (let ((s1 (math-possible-signs (nth 1 a
)))
545 (s2 (math-possible-signs (nth 2 a
))))
549 ((eq s1
2) (if (eq s2
4) 2 15))
550 ((eq s2
2) (if (memq s1
'(1 5)) 2 15))
551 ((Math-integerp (nth 2 a
))
552 (if (math-evenp (nth 2 a
))
553 (if (memq s1
'(3 6 7)) 6 4)
555 ((eq s1
6) (if (eq s2
4) 6 15))
558 (let ((s2 (math-possible-signs (nth 2 a
))))
564 ((and (memq (car a
) '(calcFunc-abs calcFunc-abssqr
))
566 (let ((s1 (math-possible-signs (nth 1 a
))))
568 ((memq s1
'(1 4 5)) 4)
570 ((and (eq (car a
) 'calcFunc-exp
) (= (length a
) 2))
571 (let ((s1 (math-possible-signs (nth 1 a
))))
574 (if (or (not origin
) (math-negp origin
))
576 (setq origin
(math-sub (or origin
0) 1))
577 (if (Math-zerop origin
) (setq origin nil
))
579 ((or (and (memq (car a
) '(calcFunc-ln calcFunc-log10
))
581 (and (eq (car a
) 'calcFunc-log
)
583 (math-known-posp (nth 2 a
))))
584 (if (math-known-nonnegp (nth 1 a
))
585 (math-possible-signs (nth 1 a
) 1)
587 ((and (eq (car a
) 'calcFunc-sqrt
) (= (length a
) 2))
588 (let ((s1 (math-possible-signs (nth 1 a
))))
589 (if (memq s1
'(2 4 6)) s1
15)))
590 ((memq (car a
) math-nonnegative-functions
) 6)
591 ((memq (car a
) math-positive-functions
) 4)
592 ((memq (car a
) math-real-functions
) 7)
593 ((memq (car a
) math-real-scalar-functions
) 7)
594 ((and (memq (car a
) math-real-if-arg-functions
)
596 (if (math-known-realp (nth 1 a
)) 7 15)))))
600 (if (Math-posp origin
)
601 (if (memq sign
'(1 2 3 8 9 10 11)) 1 7)
602 (if (memq sign
'(2 4 6 8 10 12 14)) 4 7)))
605 (cond ((eq (nth 2 a
) 'var-pi
)
607 (math-possible-signs (math-pi) origin
)
609 ((eq (nth 2 a
) 'var-e
)
611 (math-possible-signs (math-e) origin
)
613 ((eq (nth 2 a
) 'var-inf
) 4)
614 ((eq (nth 2 a
) 'var-uinf
) 13)
615 ((eq (nth 2 a
) 'var-i
) 8)
618 (math-setup-declarations)
619 (let ((decl (if (eq (car a
) 'var
)
620 (or (assq (nth 2 a
) math-decls-cache
)
622 (assq (car a
) math-decls-cache
))))
624 (memq 'int
(nth 1 decl
))
625 (not (Math-num-integerp origin
)))
628 (math-possible-signs (nth 2 decl
) origin
)
629 (if (memq 'real
(nth 1 decl
))
633 (defun math-neg-signs (s1)
635 (+ 8 (math-neg-signs (- s1
8)))
636 (+ (if (memq s1
'(1 3 5 7)) 4 0)
637 (if (memq s1
'(2 3 6 7)) 2 0)
638 (if (memq s1
'(4 5 6 7)) 1 0))))
641 ;;; Try to prove that A is an integer.
642 (defun math-known-integerp (a)
643 (eq (math-possible-types a
) 1))
645 (defun math-known-num-integerp (a)
646 (<= (math-possible-types a t
) 3))
648 (defun math-known-imagp (a)
649 (= (math-possible-types a
) 16))
652 ;;; Find the possible types of A.
653 ;;; Returns an integer with bits: 1 may be integer.
654 ;;; 2 may be integer-valued float.
655 ;;; 4 may be fraction.
656 ;;; 8 may be non-integer-valued float.
657 ;;; 16 may be imaginary.
658 ;;; 32 may be non-real, non-imaginary.
659 ;;; Real infinities count as integers for the purposes of this function.
660 (defun math-possible-types (a &optional num
)
661 (cond ((Math-objectp a
)
662 (cond ((Math-integerp a
) (if num
3 1))
663 ((Math-messy-integerp a
) (if num
3 2))
664 ((eq (car a
) 'frac
) (if num
12 4))
665 ((eq (car a
) 'float
) (if num
12 8))
667 (if (equal (nth 2 a
) (nth 3 a
))
668 (math-possible-types (nth 2 a
))
671 (if (math-known-realp (nth 1 a
)) 15 63))
673 (if (math-zerop (nth 1 a
)) 16 32))
675 (if (or (Math-equal (nth 2 a
) (math-quarter-circle nil
))
676 (Math-equal (nth 2 a
)
677 (math-neg (math-quarter-circle nil
))))
681 (let* ((t1 (math-possible-types (nth 1 a
) num
))
682 (t2 (math-possible-types (nth 2 a
) num
))
683 (t12 (logior t1 t2
)))
685 (if (> (logand t12
10) 0)
687 (if (or (= t1
4) (= t2
4) calc-prefer-frac
)
693 (if (< t2
16) 16 31))
698 ((memq (car a
) '(+ -
* %
))
699 (let* ((t1 (math-possible-types (nth 1 a
) num
))
700 (t2 (math-possible-types (nth 2 a
) num
))
701 (t12 (logior t1 t2
)))
703 (setq t1
(logand t1
15) t2
(logand t2
15) t12
(logand t12
15)))
705 (let ((mask (if (<= t12
3)
707 (if (and (or (and (<= t1
3) (= (logand t2
3) 0))
708 (and (<= t2
3) (= (logand t1
3) 0)))
709 (memq (car a
) '(+ -
)))
714 (logior (if (and (> (logand t1
5) 0) (> (logand t2
5) 0))
716 (if (> (logand t12
10) 0)
722 (if (< t2
16) 16 31))
727 (if (or (and (= t1
16) (< t2
16))
728 (and (= t2
16) (< t1
16))) 32 63)))
731 (math-possible-types (nth 1 a
)))
733 (let* ((t1 (math-possible-types (nth 1 a
) num
))
734 (t2 (math-possible-types (nth 2 a
) num
))
735 (t12 (logior t1 t2
)))
736 (if (and (<= t2
3) (math-known-nonnegp (nth 2 a
)) (< t1
16))
737 (let ((mask (logior (if (> (logand t1
3) 0) 1 0)
739 (if (> (logand t1
12) 0) 5 0))))
742 (logior (if (and (> (logand t1
5) 0) (> (logand t2
5) 0))
744 (if (> (logand t12
10) 0)
746 (if (and (math-known-nonnegp (nth 1 a
))
747 (math-known-posp (nth 2 a
)))
750 ((eq (car a
) 'calcFunc-sqrt
)
751 (let ((t1 (math-possible-signs (nth 1 a
))))
752 (logior (if (> (logand t1
2) 0) 3 0)
753 (if (> (logand t1
1) 0) 16 0)
754 (if (> (logand t1
4) 0) 15 0)
755 (if (> (logand t1
8) 0) 32 0))))
758 (while (and (setq a
(cdr a
)) (< types
63))
759 (setq types
(logior types
(math-possible-types (car a
) t
))))
761 ((or (memq (car a
) math-integer-functions
)
762 (and (memq (car a
) math-rounding-functions
)
763 (math-known-nonnegp (or (nth 2 a
) 0))))
765 ((or (memq (car a
) math-num-integer-functions
)
766 (and (memq (car a
) math-float-rounding-functions
)
767 (math-known-nonnegp (or (nth 2 a
) 0))))
769 ((eq (car a
) 'calcFunc-frac
)
771 ((and (eq (car a
) 'calcFunc-float
) (= (length a
) 2))
772 (let ((t1 (math-possible-types (nth 1 a
))))
773 (logior (if (> (logand t1
3) 0) 2 0)
774 (if (> (logand t1
12) 0) 8 0)
776 ((and (memq (car a
) '(calcFunc-abs calcFunc-abssqr
))
778 (let ((t1 (math-possible-types (nth 1 a
))))
783 (cond ((memq (nth 2 a
) '(var-e var-pi var-phi var-gamma
)) 8)
784 ((eq (nth 2 a
) 'var-inf
) 1)
785 ((eq (nth 2 a
) 'var-i
) 16)
788 (math-setup-declarations)
789 (let ((decl (if (eq (car a
) 'var
)
790 (or (assq (nth 2 a
) math-decls-cache
)
792 (assq (car a
) math-decls-cache
))))
793 (cond ((memq 'int
(nth 1 decl
))
795 ((memq 'numint
(nth 1 decl
))
797 ((memq 'frac
(nth 1 decl
))
799 ((memq 'rat
(nth 1 decl
))
801 ((memq 'float
(nth 1 decl
))
804 (math-possible-types (nth 2 decl
)))
805 ((memq 'real
(nth 1 decl
))
809 (defun math-known-evenp (a)
810 (cond ((Math-integerp a
)
812 ((Math-messy-integerp a
)
814 (math-evenp (math-trunc a
))))
816 (if (math-known-evenp (nth 1 a
))
817 (math-known-num-integerp (nth 2 a
))
818 (if (math-known-num-integerp (nth 1 a
))
819 (math-known-evenp (nth 2 a
)))))
820 ((memq (car a
) '(+ -
))
821 (or (and (math-known-evenp (nth 1 a
))
822 (math-known-evenp (nth 2 a
)))
823 (and (math-known-oddp (nth 1 a
))
824 (math-known-oddp (nth 2 a
)))))
826 (math-known-evenp (nth 1 a
)))))
828 (defun math-known-oddp (a)
829 (cond ((Math-integerp a
)
831 ((Math-messy-integerp a
)
832 (and (<= (nth 2 a
) 0)
833 (math-oddp (math-trunc a
))))
834 ((memq (car a
) '(+ -
))
835 (or (and (math-known-evenp (nth 1 a
))
836 (math-known-oddp (nth 2 a
)))
837 (and (math-known-oddp (nth 1 a
))
838 (math-known-evenp (nth 2 a
)))))
840 (math-known-oddp (nth 1 a
)))))
843 (defun calcFunc-dreal (expr)
844 (let ((types (math-possible-types expr
)))
846 (if (= (logand types
15) 0) 0
847 (math-reject-arg expr
'realp
'quiet
)))))
849 (defun calcFunc-dimag (expr)
850 (let ((types (math-possible-types expr
)))
852 (if (= (logand types
16) 0) 0
853 (math-reject-arg expr
"Expected an imaginary number")))))
855 (defun calcFunc-dpos (expr)
856 (let ((signs (math-possible-signs expr
)))
858 (if (memq signs
'(1 2 3)) 0
859 (math-reject-arg expr
'posp
'quiet
)))))
861 (defun calcFunc-dneg (expr)
862 (let ((signs (math-possible-signs expr
)))
864 (if (memq signs
'(2 4 6)) 0
865 (math-reject-arg expr
'negp
'quiet
)))))
867 (defun calcFunc-dnonneg (expr)
868 (let ((signs (math-possible-signs expr
)))
869 (if (memq signs
'(2 4 6)) 1
871 (math-reject-arg expr
'posp
'quiet
)))))
873 (defun calcFunc-dnonzero (expr)
874 (let ((signs (math-possible-signs expr
)))
875 (if (memq signs
'(1 4 5 8 9 12 13)) 1
877 (math-reject-arg expr
'nonzerop
'quiet
)))))
879 (defun calcFunc-dint (expr)
880 (let ((types (math-possible-types expr
)))
882 (if (= (logand types
1) 0) 0
883 (math-reject-arg expr
'integerp
'quiet
)))))
885 (defun calcFunc-dnumint (expr)
886 (let ((types (math-possible-types expr t
)))
888 (if (= (logand types
3) 0) 0
889 (math-reject-arg expr
'integerp
'quiet
)))))
891 (defun calcFunc-dnatnum (expr)
892 (let ((res (calcFunc-dint expr
)))
894 (calcFunc-dnonneg expr
)
897 (defun calcFunc-deven (expr)
898 (if (math-known-evenp expr
)
900 (if (or (math-known-oddp expr
)
901 (= (logand (math-possible-types expr
) 3) 0))
903 (math-reject-arg expr
"Can't tell if expression is odd or even"))))
905 (defun calcFunc-dodd (expr)
906 (if (math-known-oddp expr
)
908 (if (or (math-known-evenp expr
)
909 (= (logand (math-possible-types expr
) 3) 0))
911 (math-reject-arg expr
"Can't tell if expression is odd or even"))))
913 (defun calcFunc-drat (expr)
914 (let ((types (math-possible-types expr
)))
915 (if (memq types
'(1 4 5)) 1
916 (if (= (logand types
5) 0) 0
917 (math-reject-arg expr
"Rational number expected")))))
919 (defun calcFunc-drange (expr)
920 (math-setup-declarations)
922 (if (Math-realp expr
)
924 (if (eq (car-safe expr
) 'intv
)
926 (if (eq (car-safe expr
) 'var
)
927 (setq range
(nth 2 (or (assq (nth 2 expr
) math-decls-cache
)
929 (setq range
(nth 2 (assq (car-safe expr
) math-decls-cache
))))
931 (math-clean-set (copy-sequence range
))
932 (setq range
(math-possible-signs expr
))
935 (intv 2 (neg (var inf var-inf
)) 0)
937 (intv 3 (neg (var inf var-inf
)) 0)
938 (intv 1 0 (var inf var-inf
))
939 (vec (intv 2 (neg (var inf var-inf
)) 0)
940 (intv 1 0 (var inf var-inf
)))
941 (intv 3 0 (var inf var-inf
))
942 (intv 3 (neg (var inf var-inf
)) (var inf var-inf
))] range
)
943 (math-reject-arg expr
'realp
'quiet
)))))))
945 (defun calcFunc-dscalar (a)
946 (if (math-known-scalarp a
) 1
947 (if (math-known-matrixp a
) 0
948 (math-reject-arg a
'objectp
'quiet
))))
953 (defsubst calcFunc-neg
(a)
954 (math-normalize (list 'neg a
)))
956 (defun math-neg-fancy (a)
957 (cond ((eq (car a
) 'polar
)
960 (if (math-posp (nth 2 a
))
961 (math-sub (nth 2 a
) (math-half-circle nil
))
962 (math-add (nth 2 a
) (math-half-circle nil
)))))
964 (if (math-zerop (nth 1 a
))
966 (list 'mod
(math-sub (nth 2 a
) (nth 1 a
)) (nth 2 a
))))
968 (list 'sdev
(math-neg (nth 1 a
)) (nth 2 a
)))
970 (math-make-intv (aref [0 2 1 3] (nth 1 a
))
972 (math-neg (nth 2 a
))))
973 ((and math-simplify-only
974 (not (equal a math-simplify-only
)))
977 (math-sub (math-neg (nth 1 a
)) (nth 2 a
)))
979 (math-sub (nth 2 a
) (nth 1 a
)))
980 ((and (memq (car a
) '(* /))
981 (math-okay-neg (nth 1 a
)))
982 (list (car a
) (math-neg (nth 1 a
)) (nth 2 a
)))
983 ((and (memq (car a
) '(* /))
984 (math-okay-neg (nth 2 a
)))
985 (list (car a
) (nth 1 a
) (math-neg (nth 2 a
))))
986 ((and (memq (car a
) '(* /))
987 (or (math-objectp (nth 1 a
))
988 (and (eq (car (nth 1 a
)) '*)
989 (math-objectp (nth 1 (nth 1 a
))))))
990 (list (car a
) (math-neg (nth 1 a
)) (nth 2 a
)))
991 ((and (eq (car a
) '/)
992 (or (math-objectp (nth 2 a
))
993 (and (eq (car (nth 2 a
)) '*)
994 (math-objectp (nth 1 (nth 2 a
))))))
995 (list (car a
) (nth 1 a
) (math-neg (nth 2 a
))))
996 ((and (eq (car a
) 'var
) (memq (nth 2 a
) '(var-uinf var-nan
)))
1002 (defun math-okay-neg (a)
1003 (or (math-looks-negp a
)
1004 (eq (car-safe a
) '-
)))
1006 (defun math-neg-float (a)
1007 (list 'float
(Math-integer-neg (nth 1 a
)) (nth 2 a
)))
1010 (defun calcFunc-add (&rest rest
)
1012 (let ((a (car rest
)))
1013 (while (setq rest
(cdr rest
))
1014 (setq a
(list '+ a
(car rest
))))
1018 (defun calcFunc-sub (&rest rest
)
1020 (let ((a (car rest
)))
1021 (while (setq rest
(cdr rest
))
1022 (setq a
(list '- a
(car rest
))))
1026 (defun math-add-objects-fancy (a b
)
1027 (cond ((and (Math-numberp a
) (Math-numberp b
))
1028 (let ((aa (math-complex a
))
1029 (bb (math-complex b
)))
1031 (let ((res (list 'cplx
1032 (math-add (nth 1 aa
) (nth 1 bb
))
1033 (math-add (nth 2 aa
) (nth 2 bb
)))))
1034 (if (math-want-polar a b
)
1037 ((or (Math-vectorp a
) (Math-vectorp b
))
1038 (math-map-vec-2 'math-add a b
))
1039 ((eq (car-safe a
) 'sdev
)
1040 (if (eq (car-safe b
) 'sdev
)
1041 (math-make-sdev (math-add (nth 1 a
) (nth 1 b
))
1042 (math-hypot (nth 2 a
) (nth 2 b
)))
1043 (and (or (Math-scalarp b
)
1044 (not (Math-objvecp b
)))
1045 (math-make-sdev (math-add (nth 1 a
) b
) (nth 2 a
)))))
1046 ((and (eq (car-safe b
) 'sdev
)
1047 (or (Math-scalarp a
)
1048 (not (Math-objvecp a
))))
1049 (math-make-sdev (math-add a
(nth 1 b
)) (nth 2 b
)))
1050 ((eq (car-safe a
) 'intv
)
1051 (if (eq (car-safe b
) 'intv
)
1052 (math-make-intv (logior (logand (nth 1 a
) (nth 1 b
))
1053 (if (equal (nth 2 a
)
1054 '(neg (var inf var-inf
)))
1055 (logand (nth 1 a
) 2) 0)
1056 (if (equal (nth 2 b
)
1057 '(neg (var inf var-inf
)))
1058 (logand (nth 1 b
) 2) 0)
1059 (if (equal (nth 3 a
) '(var inf var-inf
))
1060 (logand (nth 1 a
) 1) 0)
1061 (if (equal (nth 3 b
) '(var inf var-inf
))
1062 (logand (nth 1 b
) 1) 0))
1063 (math-add (nth 2 a
) (nth 2 b
))
1064 (math-add (nth 3 a
) (nth 3 b
)))
1065 (and (or (Math-anglep b
)
1067 (not (Math-objvecp b
)))
1068 (math-make-intv (nth 1 a
)
1069 (math-add (nth 2 a
) b
)
1070 (math-add (nth 3 a
) b
)))))
1071 ((and (eq (car-safe b
) 'intv
)
1074 (not (Math-objvecp a
))))
1075 (math-make-intv (nth 1 b
)
1076 (math-add a
(nth 2 b
))
1077 (math-add a
(nth 3 b
))))
1078 ((eq (car-safe a
) 'date
)
1079 (cond ((eq (car-safe b
) 'date
)
1080 (math-add (nth 1 a
) (nth 1 b
)))
1081 ((eq (car-safe b
) 'hms
)
1082 (let ((parts (math-date-parts (nth 1 a
))))
1084 (math-add (car parts
) ; this minimizes roundoff
1086 (math-add (nth 1 parts
)
1089 (math-mul (nth 1 b
) 3600)
1090 (math-add (math-mul (nth 2 b
) 60)
1094 (list 'date
(math-add (nth 1 a
) b
)))
1096 ((eq (car-safe b
) 'date
)
1097 (math-add-objects-fancy b a
))
1098 ((and (eq (car-safe a
) 'mod
)
1099 (eq (car-safe b
) 'mod
)
1100 (equal (nth 2 a
) (nth 2 b
)))
1101 (math-make-mod (math-add (nth 1 a
) (nth 1 b
)) (nth 2 a
)))
1102 ((and (eq (car-safe a
) 'mod
)
1104 (math-make-mod (math-add (nth 1 a
) b
) (nth 2 a
)))
1105 ((and (eq (car-safe b
) 'mod
)
1107 (math-make-mod (math-add a
(nth 1 b
)) (nth 2 b
)))
1108 ((and (or (eq (car-safe a
) 'hms
) (eq (car-safe b
) 'hms
))
1109 (and (Math-anglep a
) (Math-anglep b
)))
1110 (or (eq (car-safe a
) 'hms
) (setq a
(math-to-hms a
)))
1111 (or (eq (car-safe b
) 'hms
) (setq b
(math-to-hms b
)))
1114 (math-neg (math-add (math-neg a
) (math-neg b
)))
1116 (let* ((s (math-add (nth 3 a
) (nth 3 b
)))
1117 (m (math-add (nth 2 a
) (nth 2 b
)))
1118 (h (math-add (nth 1 a
) (nth 1 b
))))
1120 (setq s
(math-add s
60)
1123 (setq m
(math-add m
60)
1128 (let* ((s (math-add (nth 3 a
) (nth 3 b
)))
1129 (m (math-add (nth 2 a
) (nth 2 b
)))
1130 (h (math-add (nth 1 a
) (nth 1 b
))))
1131 (list 'hms h m s
))))))
1132 (t (calc-record-why "*Incompatible arguments for +" a b
))))
1134 (defun math-add-symb-fancy (a b
)
1135 (or (and math-simplify-only
1136 (not (equal a math-simplify-only
))
1138 (and (eq (car-safe b
) '+)
1139 (math-add (math-add a
(nth 1 b
))
1141 (and (eq (car-safe b
) '-
)
1142 (math-sub (math-add a
(nth 1 b
))
1144 (and (eq (car-safe b
) 'neg
)
1145 (eq (car-safe (nth 1 b
)) '+)
1146 (math-sub (math-sub a
(nth 1 (nth 1 b
)))
1148 (and (or (and (Math-vectorp a
) (math-known-scalarp b
))
1149 (and (Math-vectorp b
) (math-known-scalarp a
)))
1150 (math-map-vec-2 'math-add a b
))
1151 (let ((inf (math-infinitep a
)))
1154 (let ((inf2 (math-infinitep b
)))
1156 (if (or (memq (nth 2 inf
) '(var-uinf var-nan
))
1157 (memq (nth 2 inf2
) '(var-uinf var-nan
)))
1159 (let ((dir (math-infinite-dir a inf
))
1160 (dir2 (math-infinite-dir b inf2
)))
1161 (if (and (Math-objectp dir
) (Math-objectp dir2
))
1162 (if (Math-equal dir dir2
)
1164 '(var nan var-nan
)))))
1165 (if (and (equal a
'(var inf var-inf
))
1166 (eq (car-safe b
) 'intv
)
1167 (memq (nth 1 b
) '(2 3))
1168 (equal (nth 2 b
) '(neg (var inf var-inf
))))
1169 (list 'intv
3 (nth 2 b
) a
)
1170 (if (and (equal a
'(neg (var inf var-inf
)))
1171 (eq (car-safe b
) 'intv
)
1172 (memq (nth 1 b
) '(1 3))
1173 (equal (nth 3 b
) '(var inf var-inf
)))
1174 (list 'intv
3 a
(nth 3 b
))
1177 (if (eq (car-safe a
) 'intv
)
1180 ((eq (car-safe a
) '+)
1181 (let ((temp (math-combine-sum (nth 2 a
) b nil nil t
)))
1183 (math-add (nth 1 a
) temp
))))
1184 ((eq (car-safe a
) '-
)
1185 (let ((temp (math-combine-sum (nth 2 a
) b t nil t
)))
1187 (math-add (nth 1 a
) temp
))))
1188 ((and (Math-objectp a
) (Math-objectp b
))
1191 (math-combine-sum a b nil nil nil
))))
1192 (and (Math-looks-negp b
)
1193 (list '- a
(math-neg b
)))
1194 (and (Math-looks-negp a
)
1195 (list '- b
(math-neg a
)))
1196 (and (eq (car-safe a
) 'calcFunc-idn
)
1198 (or (and (eq (car-safe b
) 'calcFunc-idn
)
1200 (list 'calcFunc-idn
(math-add (nth 1 a
) (nth 1 b
))))
1201 (and (math-square-matrixp b
)
1202 (math-add (math-mimic-ident (nth 1 a
) b
) b
))
1203 (and (math-known-scalarp b
)
1204 (math-add (nth 1 a
) b
))))
1205 (and (eq (car-safe b
) 'calcFunc-idn
)
1207 (or (and (math-square-matrixp a
)
1208 (math-add a
(math-mimic-ident (nth 1 b
) a
)))
1209 (and (math-known-scalarp a
)
1210 (math-add a
(nth 1 b
)))))
1214 (defun calcFunc-mul (&rest rest
)
1216 (let ((a (car rest
)))
1217 (while (setq rest
(cdr rest
))
1218 (setq a
(list '* a
(car rest
))))
1222 (defun math-mul-objects-fancy (a b
)
1223 (cond ((and (Math-numberp a
) (Math-numberp b
))
1225 (if (math-want-polar a b
)
1226 (let ((a (math-polar a
))
1229 (math-mul (nth 1 a
) (nth 1 b
))
1230 (math-fix-circular (math-add (nth 2 a
) (nth 2 b
)))))
1231 (setq a
(math-complex a
)
1234 (math-sub (math-mul (nth 1 a
) (nth 1 b
))
1235 (math-mul (nth 2 a
) (nth 2 b
)))
1236 (math-add (math-mul (nth 1 a
) (nth 2 b
))
1237 (math-mul (nth 2 a
) (nth 1 b
)))))))
1239 (if (Math-vectorp b
)
1240 (if (math-matrixp a
)
1241 (if (math-matrixp b
)
1242 (if (= (length (nth 1 a
)) (length b
))
1244 (math-dimension-error))
1245 (if (= (length (nth 1 a
)) 2)
1246 (if (= (length a
) (length b
))
1247 (math-mul-mats a
(list 'vec b
))
1248 (math-dimension-error))
1249 (if (= (length (nth 1 a
)) (length b
))
1250 (math-mul-mat-vec a b
)
1251 (math-dimension-error))))
1252 (if (math-matrixp b
)
1253 (if (= (length a
) (length b
))
1254 (nth 1 (math-mul-mats (list 'vec a
) b
))
1255 (math-dimension-error))
1256 (if (= (length a
) (length b
))
1257 (math-dot-product a b
)
1258 (math-dimension-error))))
1259 (math-map-vec-2 'math-mul a b
)))
1261 (math-map-vec-2 'math-mul a b
))
1262 ((eq (car-safe a
) 'sdev
)
1263 (if (eq (car-safe b
) 'sdev
)
1264 (math-make-sdev (math-mul (nth 1 a
) (nth 1 b
))
1265 (math-hypot (math-mul (nth 2 a
) (nth 1 b
))
1266 (math-mul (nth 2 b
) (nth 1 a
))))
1267 (and (or (Math-scalarp b
)
1268 (not (Math-objvecp b
)))
1269 (math-make-sdev (math-mul (nth 1 a
) b
)
1270 (math-mul (nth 2 a
) b
)))))
1271 ((and (eq (car-safe b
) 'sdev
)
1272 (or (Math-scalarp a
)
1273 (not (Math-objvecp a
))))
1274 (math-make-sdev (math-mul a
(nth 1 b
)) (math-mul a
(nth 2 b
))))
1275 ((and (eq (car-safe a
) 'intv
) (Math-anglep b
))
1277 (math-neg (math-mul a
(math-neg b
)))
1278 (math-make-intv (nth 1 a
)
1279 (math-mul (nth 2 a
) b
)
1280 (math-mul (nth 3 a
) b
))))
1281 ((and (eq (car-safe b
) 'intv
) (Math-anglep a
))
1283 ((and (eq (car-safe a
) 'intv
) (math-intv-constp a
)
1284 (eq (car-safe b
) 'intv
) (math-intv-constp b
))
1285 (let ((lo (math-mul a
(nth 2 b
)))
1286 (hi (math-mul a
(nth 3 b
))))
1287 (or (eq (car-safe lo
) 'intv
)
1288 (setq lo
(list 'intv
(if (memq (nth 1 b
) '(2 3)) 3 0) lo lo
)))
1289 (or (eq (car-safe hi
) 'intv
)
1290 (setq hi
(list 'intv
(if (memq (nth 1 b
) '(1 3)) 3 0) hi hi
)))
1291 (math-combine-intervals
1292 (nth 2 lo
) (and (or (memq (nth 1 b
) '(2 3))
1293 (math-infinitep (nth 2 lo
)))
1294 (memq (nth 1 lo
) '(2 3)))
1295 (nth 3 lo
) (and (or (memq (nth 1 b
) '(2 3))
1296 (math-infinitep (nth 3 lo
)))
1297 (memq (nth 1 lo
) '(1 3)))
1298 (nth 2 hi
) (and (or (memq (nth 1 b
) '(1 3))
1299 (math-infinitep (nth 2 hi
)))
1300 (memq (nth 1 hi
) '(2 3)))
1301 (nth 3 hi
) (and (or (memq (nth 1 b
) '(1 3))
1302 (math-infinitep (nth 3 hi
)))
1303 (memq (nth 1 hi
) '(1 3))))))
1304 ((and (eq (car-safe a
) 'mod
)
1305 (eq (car-safe b
) 'mod
)
1306 (equal (nth 2 a
) (nth 2 b
)))
1307 (math-make-mod (math-mul (nth 1 a
) (nth 1 b
)) (nth 2 a
)))
1308 ((and (eq (car-safe a
) 'mod
)
1310 (math-make-mod (math-mul (nth 1 a
) b
) (nth 2 a
)))
1311 ((and (eq (car-safe b
) 'mod
)
1313 (math-make-mod (math-mul a
(nth 1 b
)) (nth 2 b
)))
1314 ((and (eq (car-safe a
) 'hms
) (Math-realp b
))
1315 (math-with-extra-prec 2
1316 (math-to-hms (math-mul (math-from-hms a
'deg
) b
) 'deg
)))
1317 ((and (eq (car-safe b
) 'hms
) (Math-realp a
))
1319 (t (calc-record-why "*Incompatible arguments for *" a b
))))
1321 ;;; Fast function to multiply floating-point numbers.
1322 (defun math-mul-float (a b
) ; [F F F]
1323 (math-make-float (math-mul (nth 1 a
) (nth 1 b
))
1324 (+ (nth 2 a
) (nth 2 b
))))
1326 (defun math-sqr-float (a) ; [F F]
1327 (math-make-float (math-mul (nth 1 a
) (nth 1 a
))
1328 (+ (nth 2 a
) (nth 2 a
))))
1330 (defun math-intv-constp (a &optional finite
)
1331 (and (or (Math-anglep (nth 2 a
))
1332 (and (equal (nth 2 a
) '(neg (var inf var-inf
)))
1334 (memq (nth 1 a
) '(0 1)))))
1335 (or (Math-anglep (nth 3 a
))
1336 (and (equal (nth 3 a
) '(var inf var-inf
))
1338 (memq (nth 1 a
) '(0 2)))))))
1340 (defun math-mul-zero (a b
)
1341 (if (math-known-matrixp b
)
1342 (if (math-vectorp b
)
1343 (math-map-vec-2 'math-mul a b
)
1344 (math-mimic-ident 0 b
))
1345 (if (math-infinitep b
)
1347 (let ((aa nil
) (bb nil
))
1348 (if (and (eq (car-safe b
) 'intv
)
1350 (and (equal (nth 2 b
) '(neg (var inf var-inf
)))
1351 (memq (nth 1 b
) '(2 3))
1352 (setq aa
(nth 2 b
)))
1353 (and (equal (nth 3 b
) '(var inf var-inf
))
1354 (memq (nth 1 b
) '(1 3))
1355 (setq bb
(nth 3 b
)))
1357 (if (or (math-posp a
)
1359 (or (memq calc-infinite-mode
'(-1 1))
1360 (setq aa
'(neg (var inf var-inf
))
1361 bb
'(var inf var-inf
)))))
1362 (list 'intv
3 (or aa
0) (or bb
0))
1364 (math-neg (list 'intv
3 (or aa
0) (or bb
0)))
1365 '(var nan var-nan
)))
1366 (if (or (math-floatp a
) (math-floatp b
)) '(float 0 0) 0))))))
1369 (defun math-mul-symb-fancy (a b
)
1370 (or (and math-simplify-only
1371 (not (equal a math-simplify-only
))
1373 (and (Math-equal-int a
1)
1375 (and (Math-equal-int a -
1)
1377 (and (or (and (Math-vectorp a
) (math-known-scalarp b
))
1378 (and (Math-vectorp b
) (math-known-scalarp a
)))
1379 (math-map-vec-2 'math-mul a b
))
1380 (and (Math-objectp b
) (not (Math-objectp a
))
1382 (and (eq (car-safe a
) 'neg
)
1383 (math-neg (math-mul (nth 1 a
) b
)))
1384 (and (eq (car-safe b
) 'neg
)
1385 (math-neg (math-mul a
(nth 1 b
))))
1386 (and (eq (car-safe a
) '*)
1388 (math-mul (nth 2 a
) b
)))
1389 (and (eq (car-safe a
) '^
)
1390 (Math-looks-negp (nth 2 a
))
1391 (not (and (eq (car-safe b
) '^
) (Math-looks-negp (nth 2 b
))))
1392 (math-known-scalarp b t
)
1393 (math-div b
(math-normalize
1394 (list '^
(nth 1 a
) (math-neg (nth 2 a
))))))
1395 (and (eq (car-safe b
) '^
)
1396 (Math-looks-negp (nth 2 b
))
1397 (not (and (eq (car-safe a
) '^
) (Math-looks-negp (nth 2 a
))))
1398 (not (math-known-matrixp (nth 1 b
)))
1399 (math-div a
(math-normalize
1400 (list '^
(nth 1 b
) (math-neg (nth 2 b
))))))
1401 (and (eq (car-safe a
) '/)
1402 (or (math-known-scalarp a t
) (math-known-scalarp b t
))
1403 (let ((temp (math-combine-prod (nth 2 a
) b t nil t
)))
1405 (math-mul (nth 1 a
) temp
)
1406 (math-div (math-mul (nth 1 a
) b
) (nth 2 a
)))))
1407 (and (eq (car-safe b
) '/)
1408 (math-div (math-mul a
(nth 1 b
)) (nth 2 b
)))
1409 (and (eq (car-safe b
) '+)
1411 (or (Math-numberp (nth 1 b
))
1412 (Math-numberp (nth 2 b
)))
1413 (math-add (math-mul a
(nth 1 b
))
1414 (math-mul a
(nth 2 b
))))
1415 (and (eq (car-safe b
) '-
)
1417 (or (Math-numberp (nth 1 b
))
1418 (Math-numberp (nth 2 b
)))
1419 (math-sub (math-mul a
(nth 1 b
))
1420 (math-mul a
(nth 2 b
))))
1421 (and (eq (car-safe b
) '*)
1422 (Math-numberp (nth 1 b
))
1423 (not (Math-numberp a
))
1424 (math-mul (nth 1 b
) (math-mul a
(nth 2 b
))))
1425 (and (eq (car-safe a
) 'calcFunc-idn
)
1427 (or (and (eq (car-safe b
) 'calcFunc-idn
)
1429 (list 'calcFunc-idn
(math-mul (nth 1 a
) (nth 1 b
))))
1430 (and (math-known-scalarp b
)
1431 (list 'calcFunc-idn
(math-mul (nth 1 a
) b
)))
1432 (and (math-known-matrixp b
)
1433 (math-mul (nth 1 a
) b
))))
1434 (and (eq (car-safe b
) 'calcFunc-idn
)
1436 (or (and (math-known-scalarp a
)
1437 (list 'calcFunc-idn
(math-mul a
(nth 1 b
))))
1438 (and (math-known-matrixp a
)
1439 (math-mul a
(nth 1 b
)))))
1440 (and (math-identity-matrix-p a t
)
1441 (or (and (eq (car-safe b
) 'calcFunc-idn
)
1443 (list 'calcFunc-idn
(math-mul
1447 (and (math-known-scalarp b
)
1448 (list 'calcFunc-idn
(math-mul
1449 (nth 1 (nth 1 a
)) b
)
1451 (and (math-known-matrixp b
)
1452 (math-mul (nth 1 (nth 1 a
)) b
))))
1453 (and (math-identity-matrix-p b t
)
1454 (or (and (eq (car-safe a
) 'calcFunc-idn
)
1456 (list 'calcFunc-idn
(math-mul (nth 1 a
)
1459 (and (math-known-scalarp a
)
1460 (list 'calcFunc-idn
(math-mul a
(nth 1 (nth 1 b
)))
1462 (and (math-known-matrixp a
)
1463 (math-mul a
(nth 1 (nth 1 b
))))))
1464 (and (math-looks-negp b
)
1465 (math-mul (math-neg a
) (math-neg b
)))
1466 (and (eq (car-safe b
) '-
)
1468 (math-mul (math-neg a
) (math-neg b
)))
1470 ((eq (car-safe b
) '*)
1471 (let ((temp (math-combine-prod a
(nth 1 b
) nil nil t
)))
1473 (math-mul temp
(nth 2 b
)))))
1475 (math-combine-prod a b nil nil nil
)))
1476 (and (equal a
'(var nan var-nan
))
1478 (and (equal b
'(var nan var-nan
))
1480 (and (equal a
'(var uinf var-uinf
))
1482 (and (equal b
'(var uinf var-uinf
))
1484 (and (equal b
'(var inf var-inf
))
1485 (let ((s1 (math-possible-signs a
)))
1489 '(intv 3 0 (var inf var-inf
)))
1493 '(intv 3 (neg (var inf var-inf
)) 0))
1494 ((and (eq (car a
) 'intv
) (math-intv-constp a
))
1495 '(intv 3 (neg (var inf var-inf
)) (var inf var-inf
)))
1496 ((and (eq (car a
) 'cplx
)
1497 (math-zerop (nth 1 a
)))
1498 (list '* (list 'cplx
0 (calcFunc-sign (nth 2 a
))) b
))
1499 ((eq (car a
) 'polar
)
1500 (list '* (list 'polar
1 (nth 2 a
)) b
)))))
1501 (and (equal a
'(var inf var-inf
))
1506 (defun calcFunc-div (a &rest rest
)
1508 (setq a
(list '/ a
(car rest
))
1512 (defun math-div-objects-fancy (a b
)
1513 (cond ((and (Math-numberp a
) (Math-numberp b
))
1515 (cond ((math-want-polar a b
)
1516 (let ((a (math-polar a
))
1519 (math-div (nth 1 a
) (nth 1 b
))
1520 (math-fix-circular (math-sub (nth 2 a
)
1523 (setq a
(math-complex a
))
1524 (list 'cplx
(math-div (nth 1 a
) b
)
1525 (math-div (nth 2 a
) b
)))
1527 (setq a
(math-complex a
)
1531 (math-add (math-mul (nth 1 a
) (nth 1 b
))
1532 (math-mul (nth 2 a
) (nth 2 b
)))
1533 (math-sub (math-mul (nth 2 a
) (nth 1 b
))
1534 (math-mul (nth 1 a
) (nth 2 b
))))
1535 (math-add (math-sqr (nth 1 b
))
1536 (math-sqr (nth 2 b
))))))))
1538 (if (math-square-matrixp b
)
1539 (let ((n1 (length b
)))
1540 (if (Math-vectorp a
)
1541 (if (math-matrixp a
)
1542 (if (= (length a
) n1
)
1543 (math-lud-solve (math-matrix-lud b
) a b
)
1544 (if (= (length (nth 1 a
)) n1
)
1546 (math-lud-solve (math-matrix-lud
1548 (math-transpose a
) b
))
1549 (math-dimension-error)))
1550 (if (= (length a
) n1
)
1551 (math-mat-col (math-lud-solve (math-matrix-lud b
)
1552 (math-col-matrix a
) b
)
1554 (math-dimension-error)))
1555 (if (Math-equal-int a
1)
1557 (math-mul a
(calcFunc-inv b
)))))
1558 (math-reject-arg b
'square-matrixp
)))
1559 ((and (Math-vectorp a
) (Math-objectp b
))
1560 (math-map-vec-2 'math-div a b
))
1561 ((eq (car-safe a
) 'sdev
)
1562 (if (eq (car-safe b
) 'sdev
)
1563 (let ((x (math-div (nth 1 a
) (nth 1 b
))))
1565 (math-div (math-hypot (nth 2 a
)
1566 (math-mul (nth 2 b
) x
))
1568 (if (or (Math-scalarp b
)
1569 (not (Math-objvecp b
)))
1570 (math-make-sdev (math-div (nth 1 a
) b
) (math-div (nth 2 a
) b
))
1571 (math-reject-arg 'realp b
))))
1572 ((and (eq (car-safe b
) 'sdev
)
1573 (or (Math-scalarp a
)
1574 (not (Math-objvecp a
))))
1575 (let ((x (math-div a
(nth 1 b
))))
1577 (math-div (math-mul (nth 2 b
) x
) (nth 1 b
)))))
1578 ((and (eq (car-safe a
) 'intv
) (Math-anglep b
))
1580 (math-neg (math-div a
(math-neg b
)))
1581 (math-make-intv (nth 1 a
)
1582 (math-div (nth 2 a
) b
)
1583 (math-div (nth 3 a
) b
))))
1584 ((and (eq (car-safe b
) 'intv
) (Math-anglep a
))
1585 (if (or (Math-posp (nth 2 b
))
1586 (and (Math-zerop (nth 2 b
)) (or (memq (nth 1 b
) '(0 1))
1587 calc-infinite-mode
)))
1589 (math-neg (math-div (math-neg a
) b
))
1590 (let ((calc-infinite-mode 1))
1591 (math-make-intv (aref [0 2 1 3] (nth 1 b
))
1592 (math-div a
(nth 3 b
))
1593 (math-div a
(nth 2 b
)))))
1594 (if (or (Math-negp (nth 3 b
))
1595 (and (Math-zerop (nth 3 b
)) (or (memq (nth 1 b
) '(0 2))
1596 calc-infinite-mode
)))
1597 (math-neg (math-div a
(math-neg b
)))
1598 (if calc-infinite-mode
1599 '(intv 3 (neg (var inf var-inf
)) (var inf var-inf
))
1600 (math-reject-arg b
"*Division by zero")))))
1601 ((and (eq (car-safe a
) 'intv
) (math-intv-constp a
)
1602 (eq (car-safe b
) 'intv
) (math-intv-constp b
))
1603 (if (or (Math-posp (nth 2 b
))
1604 (and (Math-zerop (nth 2 b
)) (or (memq (nth 1 b
) '(0 1))
1605 calc-infinite-mode
)))
1606 (let* ((calc-infinite-mode 1)
1607 (lo (math-div a
(nth 2 b
)))
1608 (hi (math-div a
(nth 3 b
))))
1609 (or (eq (car-safe lo
) 'intv
)
1610 (setq lo
(list 'intv
(if (memq (nth 1 b
) '(2 3)) 3 0)
1612 (or (eq (car-safe hi
) 'intv
)
1613 (setq hi
(list 'intv
(if (memq (nth 1 b
) '(1 3)) 3 0)
1615 (math-combine-intervals
1616 (nth 2 lo
) (and (or (memq (nth 1 b
) '(2 3))
1617 (and (math-infinitep (nth 2 lo
))
1618 (not (math-zerop (nth 2 b
)))))
1619 (memq (nth 1 lo
) '(2 3)))
1620 (nth 3 lo
) (and (or (memq (nth 1 b
) '(2 3))
1621 (and (math-infinitep (nth 3 lo
))
1622 (not (math-zerop (nth 2 b
)))))
1623 (memq (nth 1 lo
) '(1 3)))
1624 (nth 2 hi
) (and (or (memq (nth 1 b
) '(1 3))
1625 (and (math-infinitep (nth 2 hi
))
1626 (not (math-zerop (nth 3 b
)))))
1627 (memq (nth 1 hi
) '(2 3)))
1628 (nth 3 hi
) (and (or (memq (nth 1 b
) '(1 3))
1629 (and (math-infinitep (nth 3 hi
))
1630 (not (math-zerop (nth 3 b
)))))
1631 (memq (nth 1 hi
) '(1 3)))))
1632 (if (or (Math-negp (nth 3 b
))
1633 (and (Math-zerop (nth 3 b
)) (or (memq (nth 1 b
) '(0 2))
1634 calc-infinite-mode
)))
1635 (math-neg (math-div a
(math-neg b
)))
1636 (if calc-infinite-mode
1637 '(intv 3 (neg (var inf var-inf
)) (var inf var-inf
))
1638 (math-reject-arg b
"*Division by zero")))))
1639 ((and (eq (car-safe a
) 'mod
)
1640 (eq (car-safe b
) 'mod
)
1641 (equal (nth 2 a
) (nth 2 b
)))
1642 (math-make-mod (math-div-mod (nth 1 a
) (nth 1 b
) (nth 2 a
))
1644 ((and (eq (car-safe a
) 'mod
)
1646 (math-make-mod (math-div-mod (nth 1 a
) b
(nth 2 a
)) (nth 2 a
)))
1647 ((and (eq (car-safe b
) 'mod
)
1649 (math-make-mod (math-div-mod a
(nth 1 b
) (nth 2 b
)) (nth 2 b
)))
1650 ((eq (car-safe a
) 'hms
)
1651 (if (eq (car-safe b
) 'hms
)
1652 (math-with-extra-prec 1
1653 (math-div (math-from-hms a
'deg
)
1654 (math-from-hms b
'deg
)))
1655 (math-with-extra-prec 2
1656 (math-to-hms (math-div (math-from-hms a
'deg
) b
) 'deg
))))
1657 (t (calc-record-why "*Incompatible arguments for /" a b
))))
1659 (defun math-div-by-zero (a b
)
1660 (if (math-infinitep a
)
1661 (if (or (equal a
'(var nan var-nan
))
1662 (equal b
'(var uinf var-uinf
))
1663 (memq calc-infinite-mode
'(-1 1)))
1665 '(var uinf var-uinf
))
1666 (if calc-infinite-mode
1669 (if (eq calc-infinite-mode
1)
1670 (math-mul a
'(var inf var-inf
))
1671 (if (eq calc-infinite-mode -
1)
1672 (math-mul a
'(neg (var inf var-inf
)))
1673 (if (eq (car-safe a
) 'intv
)
1674 '(intv 3 (neg (var inf var-inf
)) (var inf var-inf
))
1675 '(var uinf var-uinf
)))))
1676 (math-reject-arg a
"*Division by zero"))))
1678 (defun math-div-zero (a b
)
1679 (if (math-known-matrixp b
)
1680 (if (math-vectorp b
)
1681 (math-map-vec-2 'math-div a b
)
1682 (math-mimic-ident 0 b
))
1683 (if (equal b
'(var nan var-nan
))
1685 (if (and (eq (car-safe b
) 'intv
) (math-intv-constp b
)
1686 (not (math-posp b
)) (not (math-negp b
)))
1687 (if calc-infinite-mode
1689 (if (and (math-zerop (nth 2 b
))
1690 (memq calc-infinite-mode
'(1 -
1)))
1691 (nth 2 b
) '(neg (var inf var-inf
)))
1692 (if (and (math-zerop (nth 3 b
))
1693 (memq calc-infinite-mode
'(1 -
1)))
1694 (nth 3 b
) '(var inf var-inf
)))
1695 (math-reject-arg b
"*Division by zero"))
1698 ;; For math-div-symb-fancy
1699 (defvar math-trig-inverses
1700 '((calcFunc-sin . calcFunc-csc
)
1701 (calcFunc-cos . calcFunc-sec
)
1702 (calcFunc-tan . calcFunc-cot
)
1703 (calcFunc-sec . calcFunc-cos
)
1704 (calcFunc-csc . calcFunc-sin
)
1705 (calcFunc-cot . calcFunc-tan
)
1706 (calcFunc-sinh . calcFunc-csch
)
1707 (calcFunc-cosh . calcFunc-sech
)
1708 (calcFunc-tanh . calcFunc-coth
)
1709 (calcFunc-sech . calcFunc-cosh
)
1710 (calcFunc-csch . calcFunc-sinh
)
1711 (calcFunc-coth . calcFunc-tanh
)))
1713 (defvar math-div-trig
)
1714 (defvar math-div-non-trig
)
1716 (defun math-div-new-trig (tr)
1719 (list '* tr math-div-trig
))
1720 (setq math-div-trig tr
)))
1722 (defun math-div-new-non-trig (ntr)
1723 (if math-div-non-trig
1724 (setq math-div-non-trig
1725 (list '* ntr math-div-non-trig
))
1726 (setq math-div-non-trig ntr
)))
1728 (defun math-div-isolate-trig (expr)
1729 (if (eq (car-safe expr
) '*)
1731 (math-div-isolate-trig-term (nth 1 expr
))
1732 (math-div-isolate-trig (nth 2 expr
)))
1733 (math-div-isolate-trig-term expr
)))
1735 (defun math-div-isolate-trig-term (term)
1736 (let ((fn (assoc (car-safe term
) math-trig-inverses
)))
1739 (cons (cdr fn
) (cdr term
)))
1740 (math-div-new-non-trig term
))))
1742 (defun math-div-symb-fancy (a b
)
1743 (or (and (math-known-matrixp b
)
1744 (math-mul a
(math-pow b -
1)))
1745 (and math-simplify-only
1746 (not (equal a math-simplify-only
))
1748 (and (Math-equal-int b
1) a
)
1749 (and (Math-equal-int b -
1) (math-neg a
))
1750 (and (Math-vectorp a
) (math-known-scalarp b
)
1751 (math-map-vec-2 'math-div a b
))
1752 (and (eq (car-safe b
) '^
)
1753 (or (Math-looks-negp (nth 2 b
)) (Math-equal-int a
1))
1754 (math-mul a
(math-normalize
1755 (list '^
(nth 1 b
) (math-neg (nth 2 b
))))))
1756 (and (eq (car-safe a
) 'neg
)
1757 (math-neg (math-div (nth 1 a
) b
)))
1758 (and (eq (car-safe b
) 'neg
)
1759 (math-neg (math-div a
(nth 1 b
))))
1760 (and (eq (car-safe a
) '/)
1761 (math-div (nth 1 a
) (math-mul (nth 2 a
) b
)))
1762 (and (eq (car-safe b
) '/)
1763 (or (math-known-scalarp (nth 1 b
) t
)
1764 (math-known-scalarp (nth 2 b
) t
))
1765 (math-div (math-mul a
(nth 2 b
)) (nth 1 b
)))
1766 (and (eq (car-safe b
) 'frac
)
1767 (math-mul (math-make-frac (nth 2 b
) (nth 1 b
)) a
))
1768 (and (eq (car-safe a
) '+)
1769 (or (Math-numberp (nth 1 a
))
1770 (Math-numberp (nth 2 a
)))
1772 (math-add (math-div (nth 1 a
) b
)
1773 (math-div (nth 2 a
) b
)))
1774 (and (eq (car-safe a
) '-
)
1775 (or (Math-numberp (nth 1 a
))
1776 (Math-numberp (nth 2 a
)))
1778 (math-sub (math-div (nth 1 a
) b
)
1779 (math-div (nth 2 a
) b
)))
1780 (and (or (eq (car-safe a
) '-
)
1781 (math-looks-negp a
))
1783 (math-div (math-neg a
) (math-neg b
)))
1784 (and (eq (car-safe b
) '-
)
1786 (math-div (math-neg a
) (math-neg b
)))
1787 (and (eq (car-safe a
) 'calcFunc-idn
)
1789 (or (and (eq (car-safe b
) 'calcFunc-idn
)
1791 (list 'calcFunc-idn
(math-div (nth 1 a
) (nth 1 b
))))
1792 (and (math-known-scalarp b
)
1793 (list 'calcFunc-idn
(math-div (nth 1 a
) b
)))
1794 (and (math-known-matrixp b
)
1795 (math-div (nth 1 a
) b
))))
1796 (and (eq (car-safe b
) 'calcFunc-idn
)
1798 (or (and (math-known-scalarp a
)
1799 (list 'calcFunc-idn
(math-div a
(nth 1 b
))))
1800 (and (math-known-matrixp a
)
1801 (math-div a
(nth 1 b
)))))
1802 (and math-simplifying
1803 (let ((math-div-trig nil
)
1804 (math-div-non-trig nil
))
1805 (math-div-isolate-trig b
)
1807 (if math-div-non-trig
1808 (math-div (math-mul a math-div-trig
) math-div-non-trig
)
1809 (math-mul a math-div-trig
))
1811 (if (and calc-matrix-mode
1812 (or (math-known-matrixp a
) (math-known-matrixp b
)))
1813 (math-combine-prod a b nil t nil
)
1814 (if (eq (car-safe a
) '*)
1815 (if (eq (car-safe b
) '*)
1816 (let ((c (math-combine-prod (nth 1 a
) (nth 1 b
) nil t t
)))
1818 (math-div (math-mul c
(nth 2 a
)) (nth 2 b
))))
1819 (let ((c (math-combine-prod (nth 1 a
) b nil t t
)))
1821 (math-mul c
(nth 2 a
)))))
1822 (if (eq (car-safe b
) '*)
1823 (let ((c (math-combine-prod a
(nth 1 b
) nil t t
)))
1825 (math-div c
(nth 2 b
))))
1826 (math-combine-prod a b nil t nil
))))
1827 (and (math-infinitep a
)
1828 (if (math-infinitep b
)
1830 (if (or (equal a
'(var nan var-nan
))
1831 (equal a
'(var uinf var-uinf
)))
1833 (if (equal a
'(var inf var-inf
))
1834 (if (or (math-posp b
)
1835 (and (eq (car-safe b
) 'intv
)
1836 (math-zerop (nth 2 b
))))
1837 (if (and (eq (car-safe b
) 'intv
)
1838 (not (math-intv-constp b t
)))
1839 '(intv 3 0 (var inf var-inf
))
1841 (if (or (math-negp b
)
1842 (and (eq (car-safe b
) 'intv
)
1843 (math-zerop (nth 3 b
))))
1844 (if (and (eq (car-safe b
) 'intv
)
1845 (not (math-intv-constp b t
)))
1846 '(intv 3 (neg (var inf var-inf
)) 0)
1848 (if (and (eq (car-safe b
) 'intv
)
1849 (math-negp (nth 2 b
)) (math-posp (nth 3 b
)))
1850 '(intv 3 (neg (var inf var-inf
))
1851 (var inf var-inf
)))))))))
1852 (and (math-infinitep b
)
1853 (if (equal b
'(var nan var-nan
))
1855 (let ((calc-infinite-mode 1))
1856 (math-mul-zero b a
))))
1859 ;;; Division from the left.
1860 (defun calcFunc-ldiv (a b
)
1861 (if (math-known-scalarp a
)
1863 (math-mul (math-pow a -
1) b
)))
1865 (defun calcFunc-mod (a b
)
1866 (math-normalize (list '% a b
)))
1868 (defun math-mod-fancy (a b
)
1869 (cond ((equal b
'(var inf var-inf
))
1870 (if (or (math-posp a
) (math-zerop a
))
1874 (if (eq (car-safe a
) 'intv
)
1875 (if (math-negp (nth 2 a
))
1876 '(intv 3 0 (var inf var-inf
))
1879 ((and (eq (car-safe a
) 'mod
) (Math-realp b
) (math-posp b
))
1880 (math-make-mod (nth 1 a
) b
))
1881 ((and (eq (car-safe a
) 'intv
) (math-intv-constp a t
) (math-posp b
))
1882 (math-mod-intv a b
))
1885 (calc-record-why 'anglep b
)
1886 (calc-record-why 'anglep a
))
1890 (defun calcFunc-pow (a b
)
1891 (math-normalize (list '^ a b
)))
1893 (defun math-pow-of-zero (a b
)
1894 "Raise A to the power of B, where A is a form of zero."
1895 (if (math-floatp b
) (setq a
(math-float a
)))
1900 ;; 0^0.0, etc., are undetermined
1902 (if calc-infinite-mode
1904 (math-reject-arg (list '^ a b
) "*Indeterminate form")))
1906 ((math-known-posp b
)
1908 ;; 0^negative is undefined (let math-div handle it)
1909 ((math-known-negp b
)
1911 ;; 0^infinity is undefined
1915 ((and (eq (car b
) 'intv
)
1917 (math-negp (nth 2 b
))
1918 (math-posp (nth 3 b
)))
1919 '(intv 3 (neg (var inf var-inf
)) (var inf var-inf
)))
1920 ;; If none of the above, leave it alone.
1924 (defun math-pow-zero (a b
)
1925 (if (eq (car-safe a
) 'mod
)
1926 (math-make-mod 1 (nth 2 a
))
1927 (if (math-known-matrixp a
)
1928 (math-mimic-ident 1 a
)
1929 (if (math-infinitep a
)
1931 (if (and (eq (car a
) 'intv
) (math-intv-constp a
)
1932 (or (and (not (math-posp a
)) (not (math-negp a
)))
1933 (not (math-intv-constp a t
))))
1934 '(intv 3 (neg (var inf var-inf
)) (var inf var-inf
))
1935 (if (or (math-floatp a
) (math-floatp b
))
1936 '(float 1 0) 1))))))
1938 (defun math-pow-fancy (a b
)
1939 (cond ((and (Math-numberp a
) (Math-numberp b
))
1940 (or (if (memq (math-quarter-integer b
) '(1 2 3))
1941 (let ((sqrt (math-sqrt (if (math-floatp b
)
1942 (math-float a
) a
))))
1943 (and (Math-numberp sqrt
)
1944 (math-pow sqrt
(math-mul 2 b
))))
1945 (and (eq (car b
) 'frac
)
1946 (integerp (nth 2 b
))
1948 (let ((root (math-nth-root a
(nth 2 b
))))
1949 (and root
(math-ipow root
(nth 1 b
))))))
1950 (and (or (eq a
10) (equal a
'(float 1 1)))
1951 (math-num-integerp b
)
1952 (calcFunc-scf '(float 1 0) b
))
1953 (and calc-symbolic-mode
1955 (math-with-extra-prec 2
1957 (math-float (math-mul b
(math-ln-raw (math-float a
))))))))
1958 ((or (not (Math-objvecp a
))
1959 (not (Math-objectp b
)))
1961 (cond ((and math-simplify-only
1962 (not (equal a math-simplify-only
)))
1964 ((and (eq (car-safe a
) '*)
1967 (math-known-matrixp (nth 1 a
))
1968 (math-known-matrixp (nth 2 a
)))
1971 (not (eq calc-matrix-mode
'scalar
))
1972 (and (not (math-known-scalarp (nth 1 a
)))
1973 (not (math-known-scalarp (nth 2 a
)))))))
1975 (math-known-square-matrixp (nth 1 a
))
1976 (math-known-square-matrixp (nth 2 a
)))
1977 (math-mul (math-pow-fancy (nth 2 a
) -
1)
1978 (math-pow-fancy (nth 1 a
) -
1))
1980 ((and (eq (car-safe a
) '*)
1981 (or (math-known-num-integerp b
)
1982 (math-known-nonnegp (nth 1 a
))
1983 (math-known-nonnegp (nth 2 a
))))
1984 (math-mul (math-pow (nth 1 a
) b
)
1985 (math-pow (nth 2 a
) b
)))
1986 ((and (eq (car-safe a
) '/)
1987 (or (math-known-num-integerp b
)
1988 (math-known-nonnegp (nth 2 a
))))
1989 (math-div (math-pow (nth 1 a
) b
)
1990 (math-pow (nth 2 a
) b
)))
1991 ((and (eq (car-safe a
) '/)
1992 (math-known-nonnegp (nth 1 a
))
1993 (not (math-equal-int (nth 1 a
) 1)))
1994 (math-mul (math-pow (nth 1 a
) b
)
1995 (math-pow (math-div 1 (nth 2 a
)) b
)))
1996 ((and (eq (car-safe a
) '^
)
1997 (or (math-known-num-integerp b
)
1998 (math-known-nonnegp (nth 1 a
))))
1999 (math-pow (nth 1 a
) (math-mul (nth 2 a
) b
)))
2000 ((and (eq (car-safe a
) 'calcFunc-sqrt
)
2001 (or (math-known-num-integerp b
)
2002 (math-known-nonnegp (nth 1 a
))))
2003 (math-pow (nth 1 a
) (math-div b
2)))
2004 ((and (eq (car-safe a
) '^
)
2005 (math-known-evenp (nth 2 a
))
2006 (memq (math-quarter-integer b
) '(1 2 3))
2007 (math-known-realp (nth 1 a
)))
2008 (math-abs (math-pow (nth 1 a
) (math-mul (nth 2 a
) b
))))
2009 ((and (math-looks-negp a
)
2010 (math-known-integerp b
)
2011 (setq temp
(or (and (math-known-evenp b
)
2012 (math-pow (math-neg a
) b
))
2013 (and (math-known-oddp b
)
2014 (math-neg (math-pow (math-neg a
)
2017 ((and (eq (car-safe a
) 'calcFunc-abs
)
2018 (math-known-realp (nth 1 a
))
2019 (math-known-evenp b
))
2020 (math-pow (nth 1 a
) b
))
2022 (cond ((equal a
'(var nan var-nan
))
2025 (math-mul (math-pow -
1 b
) (math-pow (nth 1 a
) b
)))
2029 (if (math-floatp b
) '(float 0 0) 0))
2030 ((and (eq (car-safe b
) 'intv
)
2031 (math-intv-constp b
))
2032 '(intv 3 0 (var inf var-inf
)))
2034 '(var nan var-nan
))))
2037 (cond ((math-negp b
)
2038 (math-pow (math-div 1 a
) (math-neg b
)))
2039 ((not (math-posp b
))
2041 ((math-equal-int (setq scale
(calcFunc-abssqr a
)) 1)
2043 ((Math-lessp scale
1)
2044 (if (math-floatp a
) '(float 0 0) 0))
2048 '(var uinf var-uinf
))
2049 ((and (eq (car a
) 'intv
)
2050 (math-intv-constp a
))
2051 (if (Math-lessp -
1 a
)
2052 (if (math-equal-int (nth 3 a
) 1)
2054 '(intv 3 0 (var inf var-inf
)))
2055 '(intv 3 (neg (var inf var-inf
))
2056 (var inf var-inf
))))
2057 (t (list '^ a b
)))))
2058 ((and (eq (car-safe a
) 'calcFunc-idn
)
2060 (math-known-num-integerp b
))
2061 (list 'calcFunc-idn
(math-pow (nth 1 a
) b
)))
2062 (t (if (Math-objectp a
)
2063 (calc-record-why 'objectp b
)
2064 (calc-record-why 'objectp a
))
2066 ((and (eq (car-safe a
) 'sdev
) (eq (car-safe b
) 'sdev
))
2067 (if (and (math-constp a
) (math-constp b
))
2068 (math-with-extra-prec 2
2069 (let* ((ln (math-ln-raw (math-float (nth 1 a
))))
2071 (math-float (math-mul (nth 1 b
) ln
)))))
2076 (math-hypot (math-mul (nth 2 a
)
2077 (math-div (nth 1 b
) (nth 1 a
)))
2078 (math-mul (nth 2 b
) ln
))))))
2079 (let ((pow (math-pow (nth 1 a
) (nth 1 b
))))
2083 (math-hypot (math-mul (nth 2 a
)
2084 (math-div (nth 1 b
) (nth 1 a
)))
2085 (math-mul (nth 2 b
) (calcFunc-ln
2087 ((and (eq (car-safe a
) 'sdev
) (Math-numberp b
))
2089 (math-with-extra-prec 2
2090 (let ((pow (math-pow (nth 1 a
) (math-sub b
1))))
2091 (math-make-sdev (math-mul pow
(nth 1 a
))
2092 (math-mul pow
(math-mul (nth 2 a
) b
)))))
2093 (math-make-sdev (math-pow (nth 1 a
) b
)
2094 (math-mul (math-pow (nth 1 a
) (math-add b -
1))
2095 (math-mul (nth 2 a
) b
)))))
2096 ((and (eq (car-safe b
) 'sdev
) (Math-numberp a
))
2097 (math-with-extra-prec 2
2098 (let* ((ln (math-ln-raw (math-float a
)))
2099 (pow (calcFunc-exp (math-mul (nth 1 b
) ln
))))
2100 (math-make-sdev pow
(math-mul pow
(math-mul (nth 2 b
) ln
))))))
2101 ((and (eq (car-safe a
) 'intv
) (math-intv-constp a
)
2103 (or (Math-natnump b
)
2104 (Math-posp (nth 2 a
))
2105 (and (math-zerop (nth 2 a
))
2107 (and (Math-integerp b
) calc-infinite-mode
)))
2108 (Math-negp (nth 3 a
))
2109 (and (math-zerop (nth 3 a
))
2111 (and (Math-integerp b
) calc-infinite-mode
)))))
2113 (setq a
(math-abs a
)))
2114 (let ((calc-infinite-mode (if (math-zerop (nth 3 a
)) -
1 1)))
2115 (math-sort-intv (nth 1 a
)
2116 (math-pow (nth 2 a
) b
)
2117 (math-pow (nth 3 a
) b
))))
2118 ((and (eq (car-safe b
) 'intv
) (math-intv-constp b
)
2119 (Math-realp a
) (Math-posp a
))
2120 (math-sort-intv (nth 1 b
)
2121 (math-pow a
(nth 2 b
))
2122 (math-pow a
(nth 3 b
))))
2123 ((and (eq (car-safe a
) 'intv
) (math-intv-constp a
)
2124 (eq (car-safe b
) 'intv
) (math-intv-constp b
)
2125 (or (and (not (Math-negp (nth 2 a
)))
2126 (not (Math-negp (nth 2 b
))))
2127 (and (Math-posp (nth 2 a
))
2128 (not (Math-posp (nth 3 b
))))))
2129 (let ((lo (math-pow a
(nth 2 b
)))
2130 (hi (math-pow a
(nth 3 b
))))
2131 (or (eq (car-safe lo
) 'intv
)
2132 (setq lo
(list 'intv
(if (memq (nth 1 b
) '(2 3)) 3 0) lo lo
)))
2133 (or (eq (car-safe hi
) 'intv
)
2134 (setq hi
(list 'intv
(if (memq (nth 1 b
) '(1 3)) 3 0) hi hi
)))
2135 (math-combine-intervals
2136 (nth 2 lo
) (and (or (memq (nth 1 b
) '(2 3))
2137 (math-infinitep (nth 2 lo
)))
2138 (memq (nth 1 lo
) '(2 3)))
2139 (nth 3 lo
) (and (or (memq (nth 1 b
) '(2 3))
2140 (math-infinitep (nth 3 lo
)))
2141 (memq (nth 1 lo
) '(1 3)))
2142 (nth 2 hi
) (and (or (memq (nth 1 b
) '(1 3))
2143 (math-infinitep (nth 2 hi
)))
2144 (memq (nth 1 hi
) '(2 3)))
2145 (nth 3 hi
) (and (or (memq (nth 1 b
) '(1 3))
2146 (math-infinitep (nth 3 hi
)))
2147 (memq (nth 1 hi
) '(1 3))))))
2148 ((and (eq (car-safe a
) 'mod
) (eq (car-safe b
) 'mod
)
2149 (equal (nth 2 a
) (nth 2 b
)))
2150 (math-make-mod (math-pow-mod (nth 1 a
) (nth 1 b
) (nth 2 a
))
2152 ((and (eq (car-safe a
) 'mod
) (Math-anglep b
))
2153 (math-make-mod (math-pow-mod (nth 1 a
) b
(nth 2 a
)) (nth 2 a
)))
2154 ((and (eq (car-safe b
) 'mod
) (Math-anglep a
))
2155 (math-make-mod (math-pow-mod a
(nth 1 b
) (nth 2 b
)) (nth 2 b
)))
2156 ((not (Math-numberp a
))
2157 (math-reject-arg a
'numberp
))
2159 (math-reject-arg b
'numberp
))))
2161 (defun math-quarter-integer (x)
2162 (if (Math-integerp x
)
2166 (setq x
(math-quarter-integer (math-neg x
)))
2168 (if (eq (car x
) 'frac
)
2169 (if (eq (nth 2 x
) 2)
2171 (and (eq (nth 2 x
) 4)
2174 (%
(if (consp x
) (nth 1 x
) x
) 4))))
2175 (if (eq (car x
) 'float
)
2176 (if (>= (nth 2 x
) 0)
2178 (if (= (nth 2 x
) -
1)
2181 (and (= (%
(if (consp x
) (nth 1 x
) x
) 10) 5) 2))
2182 (if (= (nth 2 x
) -
2)
2185 x
(%
(if (consp x
) (nth 1 x
) x
) 100))
2187 (if (= x
75) 3)))))))))))
2189 ;;; This assumes A < M and M > 0.
2190 (defun math-pow-mod (a b m
) ; [R R R R]
2191 (if (and (Math-integerp a
) (Math-integerp b
) (Math-integerp m
))
2193 (math-div-mod 1 (math-pow-mod a
(Math-integer-neg b
) m
) m
)
2196 (math-pow-mod-step a b m
)))
2197 (math-mod (math-pow a b
) m
)))
2199 (defun math-pow-mod-step (a n m
) ; [I I I I]
2200 (math-working "pow" a
)
2205 (let ((rest (math-pow-mod-step
2206 (math-imod (math-mul a a
) m
)
2211 (math-mod (math-mul a rest
) m
)))))))
2212 (math-working "pow" val
)
2216 ;;; Compute the minimum of two real numbers. [R R R] [Public]
2217 (defun math-min (a b
)
2218 (if (and (consp a
) (eq (car a
) 'intv
))
2219 (if (and (consp b
) (eq (car b
) 'intv
))
2220 (let ((lo (nth 2 a
))
2221 (lom (memq (nth 1 a
) '(2 3)))
2223 (him (memq (nth 1 a
) '(1 3)))
2225 (if (= (setq res
(math-compare (nth 2 b
) lo
)) -
1)
2226 (setq lo
(nth 2 b
) lom
(memq (nth 1 b
) '(2 3)))
2228 (setq lom
(or lom
(memq (nth 1 b
) '(2 3))))))
2229 (if (= (setq res
(math-compare (nth 3 b
) hi
)) -
1)
2230 (setq hi
(nth 3 b
) him
(memq (nth 1 b
) '(1 3)))
2232 (setq him
(or him
(memq (nth 1 b
) '(1 3))))))
2233 (math-make-intv (+ (if lom
2 0) (if him
1 0)) lo hi
))
2234 (math-min a
(list 'intv
3 b b
)))
2235 (if (and (consp b
) (eq (car b
) 'intv
))
2236 (math-min (list 'intv
3 a a
) b
)
2237 (let ((res (math-compare a b
)))
2244 (defun calcFunc-min (&optional a
&rest b
)
2247 (if (not (or (Math-anglep a
) (eq (car a
) 'date
)
2248 (and (eq (car a
) 'intv
) (math-intv-constp a
))
2249 (math-infinitep a
)))
2250 (math-reject-arg a
'anglep
))
2251 (math-min-list a b
)))
2253 (defun math-min-list (a b
)
2255 (if (or (Math-anglep (car b
)) (eq (car b
) 'date
)
2256 (and (eq (car (car b
)) 'intv
) (math-intv-constp (car b
)))
2257 (math-infinitep (car b
)))
2258 (math-min-list (math-min a
(car b
)) (cdr b
))
2259 (math-reject-arg (car b
) 'anglep
))
2262 ;;; Compute the maximum of two real numbers. [R R R] [Public]
2263 (defun math-max (a b
)
2264 (if (or (and (consp a
) (eq (car a
) 'intv
))
2265 (and (consp b
) (eq (car b
) 'intv
)))
2266 (math-neg (math-min (math-neg a
) (math-neg b
)))
2267 (let ((res (math-compare a b
)))
2274 (defun calcFunc-max (&optional a
&rest b
)
2276 '(neg (var inf var-inf
))
2277 (if (not (or (Math-anglep a
) (eq (car a
) 'date
)
2278 (and (eq (car a
) 'intv
) (math-intv-constp a
))
2279 (math-infinitep a
)))
2280 (math-reject-arg a
'anglep
))
2281 (math-max-list a b
)))
2283 (defun math-max-list (a b
)
2285 (if (or (Math-anglep (car b
)) (eq (car b
) 'date
)
2286 (and (eq (car (car b
)) 'intv
) (math-intv-constp (car b
)))
2287 (math-infinitep (car b
)))
2288 (math-max-list (math-max a
(car b
)) (cdr b
))
2289 (math-reject-arg (car b
) 'anglep
))
2293 ;;; Compute the absolute value of A. [O O; r r] [Public]
2295 (cond ((Math-negp a
)
2300 (math-hypot (nth 1 a
) (nth 2 a
)))
2301 ((eq (car a
) 'polar
)
2304 (if (cdr (cdr (cdr a
)))
2305 (math-sqrt (calcFunc-abssqr a
))
2307 (math-hypot (nth 1 a
) (nth 2 a
))
2309 (math-abs (nth 1 a
))
2312 (list 'sdev
(math-abs (nth 1 a
)) (nth 2 a
)))
2313 ((and (eq (car a
) 'intv
) (math-intv-constp a
))
2316 (let* ((nlo (math-neg (nth 2 a
)))
2317 (res (math-compare nlo
(nth 3 a
))))
2319 (math-make-intv (if (memq (nth 1 a
) '(0 1)) 2 3) 0 nlo
))
2321 (math-make-intv (if (eq (nth 1 a
) 0) 2 3) 0 nlo
))
2323 (math-make-intv (if (memq (nth 1 a
) '(0 2)) 2 3)
2325 ((math-looks-negp a
)
2326 (list 'calcFunc-abs
(math-neg a
)))
2327 ((let ((signs (math-possible-signs a
)))
2328 (or (and (memq signs
'(2 4 6)) a
)
2329 (and (memq signs
'(1 3)) (math-neg a
)))))
2330 ((let ((inf (math-infinitep a
)))
2332 (if (equal inf
'(var nan var-nan
))
2334 '(var inf var-inf
)))))
2335 (t (calc-record-why 'numvecp a
)
2336 (list 'calcFunc-abs a
))))
2338 (defalias 'calcFunc-abs
'math-abs
)
2340 (defun math-float-fancy (a)
2341 (cond ((eq (car a
) 'intv
)
2342 (cons (car a
) (cons (nth 1 a
) (mapcar 'math-float
(nthcdr 2 a
)))))
2343 ((and (memq (car a
) '(* /))
2344 (math-numberp (nth 1 a
)))
2345 (list (car a
) (math-float (nth 1 a
))
2346 (list 'calcFunc-float
(nth 2 a
))))
2347 ((and (eq (car a
) '/)
2348 (eq (car (nth 1 a
)) '*)
2349 (math-numberp (nth 1 (nth 1 a
))))
2350 (list '* (math-float (nth 1 (nth 1 a
)))
2351 (list 'calcFunc-float
(list '/ (nth 2 (nth 1 a
)) (nth 2 a
)))))
2352 ((math-infinitep a
) a
)
2353 ((eq (car a
) 'calcFunc-float
) a
)
2354 ((let ((func (assq (car a
) '((calcFunc-floor . calcFunc-ffloor
)
2355 (calcFunc-ceil . calcFunc-fceil
)
2356 (calcFunc-trunc . calcFunc-ftrunc
)
2357 (calcFunc-round . calcFunc-fround
)
2358 (calcFunc-rounde . calcFunc-frounde
)
2359 (calcFunc-roundu . calcFunc-froundu
)))))
2360 (and func
(cons (cdr func
) (cdr a
)))))
2361 (t (math-reject-arg a
'objectp
))))
2363 (defalias 'calcFunc-float
'math-float
)
2365 ;; The variable math-trunc-prec is local to math-trunc in calc-misc.el,
2366 ;; but used by math-trunc-fancy which is called by math-trunc.
2367 (defvar math-trunc-prec
)
2369 (defun math-trunc-fancy (a)
2370 (cond ((eq (car a
) 'frac
) (math-quotient (nth 1 a
) (nth 2 a
)))
2371 ((eq (car a
) 'cplx
) (math-trunc (nth 1 a
)))
2372 ((eq (car a
) 'polar
) (math-trunc (math-complex a
)))
2373 ((eq (car a
) 'hms
) (list 'hms
(nth 1 a
) 0 0))
2374 ((eq (car a
) 'date
) (list 'date
(math-trunc (nth 1 a
))))
2376 (if (math-messy-integerp (nth 2 a
))
2377 (math-trunc (math-make-mod (nth 1 a
) (math-trunc (nth 2 a
))))
2378 (math-make-mod (math-trunc (nth 1 a
)) (nth 2 a
))))
2380 (math-make-intv (+ (if (and (equal (nth 2 a
) '(neg (var inf var-inf
)))
2381 (memq (nth 1 a
) '(0 1)))
2383 (if (and (equal (nth 3 a
) '(var inf var-inf
))
2384 (memq (nth 1 a
) '(0 2)))
2386 (if (and (Math-negp (nth 2 a
))
2387 (Math-num-integerp (nth 2 a
))
2388 (memq (nth 1 a
) '(0 1)))
2389 (math-add (math-trunc (nth 2 a
)) 1)
2390 (math-trunc (nth 2 a
)))
2391 (if (and (Math-posp (nth 3 a
))
2392 (Math-num-integerp (nth 3 a
))
2393 (memq (nth 1 a
) '(0 2)))
2394 (math-add (math-trunc (nth 3 a
)) -
1)
2395 (math-trunc (nth 3 a
)))))
2396 ((math-provably-integerp a
) a
)
2398 (math-map-vec (function (lambda (x) (math-trunc x math-trunc-prec
))) a
))
2400 (if (or (math-posp a
) (math-negp a
))
2402 '(var nan var-nan
)))
2403 ((math-to-integer a
))
2404 (t (math-reject-arg a
'numberp
))))
2406 (defun math-trunc-special (a prec
)
2407 (if (Math-messy-integerp prec
)
2408 (setq prec
(math-trunc prec
)))
2410 (math-reject-arg prec
'fixnump
))
2411 (if (and (<= prec
0)
2412 (math-provably-integerp a
))
2414 (calcFunc-scf (math-trunc (let ((calc-prefer-frac t
))
2415 (calcFunc-scf a prec
)))
2418 (defun math-to-integer (a)
2419 (let ((func (assq (car-safe a
) '((calcFunc-ffloor . calcFunc-floor
)
2420 (calcFunc-fceil . calcFunc-ceil
)
2421 (calcFunc-ftrunc . calcFunc-trunc
)
2422 (calcFunc-fround . calcFunc-round
)
2423 (calcFunc-frounde . calcFunc-rounde
)
2424 (calcFunc-froundu . calcFunc-roundu
)))))
2425 (and func
(= (length a
) 2)
2426 (cons (cdr func
) (cdr a
)))))
2428 (defun calcFunc-ftrunc (a &optional prec
)
2429 (if (and (Math-messy-integerp a
)
2430 (or (not prec
) (and (integerp prec
)
2433 (math-float (math-trunc a prec
))))
2435 ;; The variable math-floor-prec is local to math-floor in calc-misc.el,
2436 ;; but used by math-floor-fancy which is called by math-floor.
2437 (defvar math-floor-prec
)
2439 (defun math-floor-fancy (a)
2440 (cond ((math-provably-integerp a
) a
)
2442 (if (or (math-posp a
)
2443 (and (math-zerop (nth 2 a
))
2444 (math-zerop (nth 3 a
))))
2446 (math-add (math-trunc a
) -
1)))
2447 ((eq (car a
) 'date
) (list 'date
(math-floor (nth 1 a
))))
2449 (math-make-intv (+ (if (and (equal (nth 2 a
) '(neg (var inf var-inf
)))
2450 (memq (nth 1 a
) '(0 1)))
2452 (if (and (equal (nth 3 a
) '(var inf var-inf
))
2453 (memq (nth 1 a
) '(0 2)))
2455 (math-floor (nth 2 a
))
2456 (if (and (Math-num-integerp (nth 3 a
))
2457 (memq (nth 1 a
) '(0 2)))
2458 (math-add (math-floor (nth 3 a
)) -
1)
2459 (math-floor (nth 3 a
)))))
2461 (math-map-vec (function (lambda (x) (math-floor x math-floor-prec
))) a
))
2463 (if (or (math-posp a
) (math-negp a
))
2465 '(var nan var-nan
)))
2466 ((math-to-integer a
))
2467 (t (math-reject-arg a
'anglep
))))
2469 (defun math-floor-special (a prec
)
2470 (if (Math-messy-integerp prec
)
2471 (setq prec
(math-trunc prec
)))
2473 (math-reject-arg prec
'fixnump
))
2474 (if (and (<= prec
0)
2475 (math-provably-integerp a
))
2477 (calcFunc-scf (math-floor (let ((calc-prefer-frac t
))
2478 (calcFunc-scf a prec
)))
2481 (defun calcFunc-ffloor (a &optional prec
)
2482 (if (and (Math-messy-integerp a
)
2483 (or (not prec
) (and (integerp prec
)
2486 (math-float (math-floor a prec
))))
2488 ;;; Coerce A to be an integer (by truncation toward plus infinity). [I N]
2489 (defun math-ceiling (a &optional prec
) ; [Public]
2491 (if (Math-messy-integerp prec
)
2492 (setq prec
(math-trunc prec
)))
2494 (math-reject-arg prec
'fixnump
))
2495 (if (and (<= prec
0)
2496 (math-provably-integerp a
))
2498 (calcFunc-scf (math-ceiling (let ((calc-prefer-frac t
))
2499 (calcFunc-scf a prec
)))
2501 ((Math-integerp a
) a
)
2502 ((Math-messy-integerp a
) (math-trunc a
))
2505 (math-add (math-trunc a
) 1)
2507 ((math-provably-integerp a
) a
)
2509 (if (or (math-negp a
)
2510 (and (math-zerop (nth 2 a
))
2511 (math-zerop (nth 3 a
))))
2513 (math-add (math-trunc a
) 1)))
2514 ((eq (car a
) 'date
) (list 'date
(math-ceiling (nth 1 a
))))
2516 (math-make-intv (+ (if (and (equal (nth 2 a
) '(neg (var inf var-inf
)))
2517 (memq (nth 1 a
) '(0 1)))
2519 (if (and (equal (nth 3 a
) '(var inf var-inf
))
2520 (memq (nth 1 a
) '(0 2)))
2522 (if (and (Math-num-integerp (nth 2 a
))
2523 (memq (nth 1 a
) '(0 1)))
2524 (math-add (math-floor (nth 2 a
)) 1)
2525 (math-ceiling (nth 2 a
)))
2526 (math-ceiling (nth 3 a
))))
2528 (math-map-vec (function (lambda (x) (math-ceiling x prec
))) a
))
2530 (if (or (math-posp a
) (math-negp a
))
2532 '(var nan var-nan
)))
2533 ((math-to-integer a
))
2534 (t (math-reject-arg a
'anglep
))))
2536 (defalias 'calcFunc-ceil
'math-ceiling
)
2538 (defun calcFunc-fceil (a &optional prec
)
2539 (if (and (Math-messy-integerp a
)
2540 (or (not prec
) (and (integerp prec
)
2543 (math-float (math-ceiling a prec
))))
2545 (defvar math-rounding-mode nil
)
2547 ;;; Coerce A to be an integer (by rounding to nearest integer). [I N] [Public]
2548 (defun math-round (a &optional prec
)
2550 (if (Math-messy-integerp prec
)
2551 (setq prec
(math-trunc prec
)))
2553 (math-reject-arg prec
'fixnump
))
2554 (if (and (<= prec
0)
2555 (math-provably-integerp a
))
2557 (calcFunc-scf (math-round (let ((calc-prefer-frac t
))
2558 (calcFunc-scf a prec
)))
2561 (if (Math-num-integerp a
)
2563 (if (and (Math-negp a
) (not (eq math-rounding-mode
'up
)))
2564 (math-neg (math-round (math-neg a
)))
2565 (setq a
(let ((calc-angle-mode 'deg
)) ; in case of HMS forms
2566 (math-add a
(if (Math-ratp a
)
2569 (if (and (Math-num-integerp a
) (eq math-rounding-mode
'even
))
2571 (setq a
(math-floor a
))
2573 (setq a
(math-sub a
1)))
2576 ((math-provably-integerp a
) a
)
2577 ((eq (car a
) 'date
) (list 'date
(math-round (nth 1 a
))))
2579 (math-floor (math-add a
'(frac 1 2))))
2581 (math-map-vec (function (lambda (x) (math-round x prec
))) a
))
2583 (if (or (math-posp a
) (math-negp a
))
2585 '(var nan var-nan
)))
2586 ((math-to-integer a
))
2587 (t (math-reject-arg a
'anglep
))))
2589 (defalias 'calcFunc-round
'math-round
)
2591 (defsubst calcFunc-rounde
(a &optional prec
)
2592 (let ((math-rounding-mode 'even
))
2593 (math-round a prec
)))
2595 (defsubst calcFunc-roundu
(a &optional prec
)
2596 (let ((math-rounding-mode 'up
))
2597 (math-round a prec
)))
2599 (defun calcFunc-fround (a &optional prec
)
2600 (if (and (Math-messy-integerp a
)
2601 (or (not prec
) (and (integerp prec
)
2604 (math-float (math-round a prec
))))
2606 (defsubst calcFunc-frounde
(a &optional prec
)
2607 (let ((math-rounding-mode 'even
))
2608 (calcFunc-fround a prec
)))
2610 (defsubst calcFunc-froundu
(a &optional prec
)
2611 (let ((math-rounding-mode 'up
))
2612 (calcFunc-fround a prec
)))
2614 ;;; Pull floating-point values apart into mantissa and exponent.
2615 (defun calcFunc-mant (x)
2617 (if (or (Math-ratp x
)
2620 (list 'float
(nth 1 x
) (- 1 (math-numdigs (nth 1 x
)))))
2621 (calc-record-why 'realp x
)
2622 (list 'calcFunc-mant x
)))
2624 (defun calcFunc-xpon (x)
2626 (if (or (Math-ratp x
)
2629 (math-normalize (+ (nth 2 x
) (1- (math-numdigs (nth 1 x
))))))
2630 (calc-record-why 'realp x
)
2631 (list 'calcFunc-xpon x
)))
2633 (defun calcFunc-scf (x n
)
2639 (math-scale-int x n
)
2640 (math-div x
(math-scale-int 1 (- n
)))))
2643 (math-make-frac (math-scale-int (nth 1 x
) n
) (nth 2 x
))
2644 (math-make-frac (nth 1 x
) (math-scale-int (nth 2 x
) (- n
)))))
2645 ((eq (car x
) 'float
)
2646 (math-make-float (nth 1 x
) (+ (nth 2 x
) n
)))
2647 ((memq (car x
) '(cplx sdev
))
2650 (calcFunc-scf (nth 1 x
) n
)
2651 (calcFunc-scf (nth 2 x
) n
))))
2652 ((memq (car x
) '(polar mod
))
2655 (calcFunc-scf (nth 1 x
) n
)
2661 (calcFunc-scf (nth 2 x
) n
)
2662 (calcFunc-scf (nth 3 x
) n
))))
2664 (math-map-vec (function (lambda (x) (calcFunc-scf x n
))) x
))
2668 (calc-record-why 'realp x
)
2669 (list 'calcFunc-scf x n
)))
2670 (if (math-messy-integerp n
)
2671 (if (< (nth 2 n
) 10)
2672 (calcFunc-scf x
(math-trunc n
))
2674 (if (math-integerp n
)
2676 (calc-record-why 'integerp n
)
2677 (list 'calcFunc-scf x n
)))))
2680 (defun calcFunc-incr (x &optional step relative-to
)
2681 (or step
(setq step
1))
2682 (cond ((not (Math-integerp step
))
2683 (math-reject-arg step
'integerp
))
2686 ((eq (car x
) 'float
)
2687 (if (and (math-zerop x
)
2688 (eq (car-safe relative-to
) 'float
))
2690 (calcFunc-scf relative-to
(- 1 calc-internal-prec
)))
2691 (math-add-float x
(math-make-float
2694 (- (math-numdigs (nth 1 x
))
2695 calc-internal-prec
))))))
2697 (if (Math-integerp (nth 1 x
))
2699 (math-add x
(list 'hms
0 0 step
))))
2701 (math-reject-arg x
'realp
))))
2703 (defsubst calcFunc-decr
(x &optional step relative-to
)
2704 (calcFunc-incr x
(math-neg (or step
1)) relative-to
))
2706 (defun calcFunc-percent (x)
2707 (if (math-objectp x
)
2708 (let ((calc-prefer-frac nil
))
2710 (list 'calcFunc-percent x
)))
2712 (defun calcFunc-relch (x y
)
2713 (if (and (math-objectp x
) (math-objectp y
))
2714 (math-div (math-sub y x
) x
)
2715 (list 'calcFunc-relch x y
)))
2717 ;;; Compute the absolute value squared of A. [F N] [Public]
2718 (defun calcFunc-abssqr (a)
2719 (cond ((Math-realp a
)
2722 (math-add (math-sqr (nth 1 a
))
2723 (math-sqr (nth 2 a
))))
2724 ((eq (car a
) 'polar
)
2725 (math-sqr (nth 1 a
)))
2726 ((and (memq (car a
) '(sdev intv
)) (math-constp a
))
2727 (math-sqr (math-abs a
)))
2729 (math-reduce-vec 'math-add
(math-map-vec 'calcFunc-abssqr a
)))
2730 ((math-known-realp a
)
2732 ((let ((inf (math-infinitep a
)))
2734 (math-mul (calcFunc-abssqr (math-infinite-dir a inf
)) inf
))))
2735 (t (calc-record-why 'numvecp a
)
2736 (list 'calcFunc-abssqr a
))))
2738 (defsubst math-sqr
(a)
2743 (defun calcFunc-idiv (a b
) ; [I I I] [Public]
2744 (cond ((and (Math-natnump a
) (Math-natnump b
) (not (eq b
0)))
2745 (math-quotient a b
))
2748 (let ((calc-prefer-frac t
))
2749 (math-floor (math-div a b
)))
2750 (math-reject-arg b
'realp
)))
2751 ((eq (car-safe a
) 'hms
)
2752 (if (eq (car-safe b
) 'hms
)
2753 (let ((calc-prefer-frac t
))
2754 (math-floor (math-div a b
)))
2755 (math-reject-arg b
'hmsp
)))
2756 ((and (or (eq (car-safe a
) 'intv
) (Math-realp a
))
2757 (or (eq (car-safe b
) 'intv
) (Math-realp b
)))
2758 (math-floor (math-div a b
)))
2759 ((or (math-infinitep a
)
2762 (t (math-reject-arg a
'anglep
))))
2765 ;;; Combine two terms being added, if possible.
2766 (defun math-combine-sum (a b nega negb scalar-okay
)
2767 (if (and scalar-okay
(Math-objvecp a
) (Math-objvecp b
))
2768 (math-add-or-sub a b nega negb
)
2769 (let ((amult 1) (bmult 1))
2771 (cond ((and (eq (car a
) '*)
2772 (Math-objectp (nth 1 a
)))
2773 (setq amult
(nth 1 a
)
2775 ((and (eq (car a
) '/)
2776 (Math-objectp (nth 2 a
)))
2777 (setq amult
(if (Math-integerp (nth 2 a
))
2778 (list 'frac
1 (nth 2 a
))
2779 (math-div 1 (nth 2 a
)))
2785 (cond ((and (eq (car b
) '*)
2786 (Math-objectp (nth 1 b
)))
2787 (setq bmult
(nth 1 b
)
2789 ((and (eq (car b
) '/)
2790 (Math-objectp (nth 2 b
)))
2791 (setq bmult
(if (Math-integerp (nth 2 b
))
2792 (list 'frac
1 (nth 2 b
))
2793 (math-div 1 (nth 2 b
)))
2798 (and (if math-simplifying
2802 (if nega
(setq amult
(math-neg amult
)))
2803 (if negb
(setq bmult
(math-neg bmult
)))
2804 (setq amult
(math-add amult bmult
))
2805 (math-mul amult a
))))))
2807 (defun math-add-or-sub (a b aneg bneg
)
2808 (if aneg
(setq a
(math-neg a
)))
2809 (if bneg
(setq b
(math-neg b
)))
2810 (if (or (Math-vectorp a
) (Math-vectorp b
))
2811 (math-normalize (list '+ a b
))
2814 (defvar math-combine-prod-e
'(var e var-e
))
2816 ;;; The following is expanded out four ways for speed.
2818 ;; math-unit-prefixes is defined in calc-units.el,
2820 (defvar math-unit-prefixes
)
2822 (defun math-combine-prod (a b inva invb scalar-okay
)
2824 ((or (and inva
(Math-zerop a
))
2825 (and invb
(Math-zerop b
)))
2827 ((and scalar-okay
(Math-objvecp a
) (Math-objvecp b
))
2828 (setq a
(math-mul-or-div a b inva invb
))
2829 (and (Math-objvecp a
)
2831 ((and (eq (car-safe a
) '^
)
2833 (math-looks-negp (nth 2 a
)))
2834 (math-mul (math-pow (nth 1 a
) (math-neg (nth 2 a
))) b
))
2835 ((and (eq (car-safe b
) '^
)
2837 (math-looks-negp (nth 2 b
)))
2838 (math-mul a
(math-pow (nth 1 b
) (math-neg (nth 2 b
)))))
2839 ((and math-simplifying
2840 (math-combine-prod-trig a b
)))
2841 (t (let ((apow 1) (bpow 1))
2843 (cond ((and (eq (car a
) '^
)
2844 (or math-simplifying
2845 (Math-numberp (nth 2 a
))))
2846 (setq apow
(nth 2 a
)
2848 ((eq (car a
) 'calcFunc-sqrt
)
2849 (setq apow
'(frac 1 2)
2851 ((and (eq (car a
) 'calcFunc-exp
)
2852 (or math-simplifying
2853 (Math-numberp (nth 1 a
))))
2854 (setq apow
(nth 1 a
)
2855 a math-combine-prod-e
))))
2856 (and (consp a
) (eq (car a
) 'frac
)
2857 (Math-lessp (nth 1 a
) (nth 2 a
))
2858 (setq a
(math-div 1 a
) apow
(math-neg apow
)))
2860 (cond ((and (eq (car b
) '^
)
2861 (or math-simplifying
2862 (Math-numberp (nth 2 b
))))
2863 (setq bpow
(nth 2 b
)
2865 ((eq (car b
) 'calcFunc-sqrt
)
2866 (setq bpow
'(frac 1 2)
2868 ((and (eq (car b
) 'calcFunc-exp
)
2869 (or math-simplifying
2870 (Math-numberp (nth 1 b
))))
2871 (setq bpow
(nth 1 b
)
2872 b math-combine-prod-e
))))
2873 (and (consp b
) (eq (car b
) 'frac
)
2874 (Math-lessp (nth 1 b
) (nth 2 b
))
2875 (setq b
(math-div 1 b
) bpow
(math-neg bpow
)))
2876 (if inva
(setq apow
(math-neg apow
)))
2877 (if invb
(setq bpow
(math-neg bpow
)))
2878 (or (and (if math-simplifying
2879 (math-commutative-equal a b
)
2881 (let ((sumpow (math-add apow bpow
)))
2882 (and (or (not (Math-integerp a
))
2884 (eq (eq (car-safe apow
) 'frac
)
2885 (eq (car-safe bpow
) 'frac
)))
2887 (and (math-looks-negp sumpow
)
2888 (Math-ratp a
) (Math-posp a
)
2889 (setq a
(math-div 1 a
)
2890 sumpow
(math-neg sumpow
)))
2891 (cond ((equal sumpow
'(frac 1 2))
2892 (list 'calcFunc-sqrt a
))
2893 ((equal sumpow
'(frac -
1 2))
2894 (math-div 1 (list 'calcFunc-sqrt a
)))
2895 ((and (eq a math-combine-prod-e
)
2897 (list 'calcFunc-exp sumpow
))
2901 (inexact-result (list '^ a sumpow
)))))))))
2902 (and math-simplifying-units
2903 math-combining-units
2904 (let* ((ua (math-check-unit-name a
))
2907 (eq ua
(setq ub
(math-check-unit-name b
)))
2909 (setq ua
(if (eq (nth 1 a
) (car ua
))
2911 (nth 1 (assq (aref (symbol-name (nth 1 a
))
2913 math-unit-prefixes
)))
2914 ub
(if (eq (nth 1 b
) (car ub
))
2916 (nth 1 (assq (aref (symbol-name (nth 1 b
))
2918 math-unit-prefixes
))))
2919 (if (Math-lessp ua ub
)
2921 (setq temp a a b b temp
2922 temp ua ua ub ub temp
2923 temp apow apow bpow bpow temp
)))
2924 (math-mul (math-pow (math-div ua ub
) apow
)
2925 (math-pow b
(math-add apow bpow
)))))))
2926 (and (equal apow bpow
)
2927 (Math-natnump a
) (Math-natnump b
)
2928 (cond ((equal apow
'(frac 1 2))
2929 (list 'calcFunc-sqrt
(math-mul a b
)))
2930 ((equal apow
'(frac -
1 2))
2931 (math-div 1 (list 'calcFunc-sqrt
(math-mul a b
))))
2933 (setq a
(math-mul a b
))
2936 (inexact-result (list '^ a apow
)))))))))))
2938 (defun math-combine-prod-trig (a b
)
2940 ((and (eq (car-safe a
) 'calcFunc-sin
)
2941 (eq (car-safe b
) 'calcFunc-csc
)
2942 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2944 ((and (eq (car-safe a
) 'calcFunc-sin
)
2945 (eq (car-safe b
) 'calcFunc-sec
)
2946 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2947 (cons 'calcFunc-tan
(cdr a
)))
2948 ((and (eq (car-safe a
) 'calcFunc-sin
)
2949 (eq (car-safe b
) 'calcFunc-cot
)
2950 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2951 (cons 'calcFunc-cos
(cdr a
)))
2952 ((and (eq (car-safe a
) 'calcFunc-cos
)
2953 (eq (car-safe b
) 'calcFunc-sec
)
2954 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2956 ((and (eq (car-safe a
) 'calcFunc-cos
)
2957 (eq (car-safe b
) 'calcFunc-csc
)
2958 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2959 (cons 'calcFunc-cot
(cdr a
)))
2960 ((and (eq (car-safe a
) 'calcFunc-cos
)
2961 (eq (car-safe b
) 'calcFunc-tan
)
2962 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2963 (cons 'calcFunc-sin
(cdr a
)))
2964 ((and (eq (car-safe a
) 'calcFunc-tan
)
2965 (eq (car-safe b
) 'calcFunc-cot
)
2966 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2968 ((and (eq (car-safe a
) 'calcFunc-tan
)
2969 (eq (car-safe b
) 'calcFunc-csc
)
2970 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2971 (cons 'calcFunc-sec
(cdr a
)))
2972 ((and (eq (car-safe a
) 'calcFunc-sec
)
2973 (eq (car-safe b
) 'calcFunc-cot
)
2974 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2975 (cons 'calcFunc-csc
(cdr a
)))
2976 ((and (eq (car-safe a
) 'calcFunc-sinh
)
2977 (eq (car-safe b
) 'calcFunc-csch
)
2978 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2980 ((and (eq (car-safe a
) 'calcFunc-sinh
)
2981 (eq (car-safe b
) 'calcFunc-sech
)
2982 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2983 (cons 'calcFunc-tanh
(cdr a
)))
2984 ((and (eq (car-safe a
) 'calcFunc-sinh
)
2985 (eq (car-safe b
) 'calcFunc-coth
)
2986 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2987 (cons 'calcFunc-cosh
(cdr a
)))
2988 ((and (eq (car-safe a
) 'calcFunc-cosh
)
2989 (eq (car-safe b
) 'calcFunc-sech
)
2990 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2992 ((and (eq (car-safe a
) 'calcFunc-cosh
)
2993 (eq (car-safe b
) 'calcFunc-csch
)
2994 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2995 (cons 'calcFunc-coth
(cdr a
)))
2996 ((and (eq (car-safe a
) 'calcFunc-cosh
)
2997 (eq (car-safe b
) 'calcFunc-tanh
)
2998 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
2999 (cons 'calcFunc-sinh
(cdr a
)))
3000 ((and (eq (car-safe a
) 'calcFunc-tanh
)
3001 (eq (car-safe b
) 'calcFunc-coth
)
3002 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
3004 ((and (eq (car-safe a
) 'calcFunc-tanh
)
3005 (eq (car-safe b
) 'calcFunc-csch
)
3006 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
3007 (cons 'calcFunc-sech
(cdr a
)))
3008 ((and (eq (car-safe a
) 'calcFunc-sech
)
3009 (eq (car-safe b
) 'calcFunc-coth
)
3010 (= 0 (math-simplify (math-sub (cdr a
) (cdr b
)))))
3011 (cons 'calcFunc-csch
(cdr a
)))
3015 (defun math-mul-or-div (a b ainv binv
)
3016 (if (or (Math-vectorp a
) (Math-vectorp b
))
3020 (list '/ (math-div 1 a
) b
)
3027 (math-div (math-div 1 a
) b
)
3033 ;; The variable math-com-bterms is local to math-commutative-equal,
3034 ;; but is used by math-commutative collect, which is called by
3035 ;; math-commutative-equal.
3036 (defvar math-com-bterms
)
3038 (defun math-commutative-equal (a b
)
3039 (if (memq (car-safe a
) '(+ -
))
3040 (and (memq (car-safe b
) '(+ -
))
3041 (let ((math-com-bterms nil
) aterms p
)
3042 (math-commutative-collect b nil
)
3043 (setq aterms math-com-bterms math-com-bterms nil
)
3044 (math-commutative-collect a nil
)
3045 (and (= (length aterms
) (length math-com-bterms
))
3049 (setq p math-com-bterms
)
3050 (while (and p
(not (equal (car aterms
)
3054 (setq math-com-bterms
(delq (car p
) math-com-bterms
)
3055 aterms
(cdr aterms
)))
3059 (defun math-commutative-collect (b neg
)
3060 (if (eq (car-safe b
) '+)
3062 (math-commutative-collect (nth 1 b
) neg
)
3063 (math-commutative-collect (nth 2 b
) neg
))
3064 (if (eq (car-safe b
) '-
)
3066 (math-commutative-collect (nth 1 b
) neg
)
3067 (math-commutative-collect (nth 2 b
) (not neg
)))
3068 (setq math-com-bterms
(cons (if neg
(math-neg b
) b
) math-com-bterms
)))))
3070 (provide 'calc-arith
)
3072 ;;; arch-tag: 6c396b5b-14c6-40ed-bb2a-7cc2e8111465
3073 ;;; calc-arith.el ends here
