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