Mercurial > emacs
comparison lisp/calc/calc-arith.el @ 88155:d7ddb3e565de
sync with trunk
author | Henrik Enberg <henrik.enberg@telia.com> |
---|---|
date | Mon, 16 Jan 2006 00:03:54 +0000 |
parents | 0d8b17d428b5 |
children |
comparison
equal
deleted
inserted
replaced
88154:8ce476d3ba36 | 88155:d7ddb3e565de |
---|---|
1 ;;; calc-arith.el --- arithmetic functions for Calc | 1 ;;; calc-arith.el --- arithmetic functions for Calc |
2 | 2 |
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. | 3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, |
4 ;; 2005 Free Software Foundation, Inc. | |
4 | 5 |
5 ;; Author: David Gillespie <daveg@synaptics.com> | 6 ;; Author: David Gillespie <daveg@synaptics.com> |
6 ;; Maintainers: D. Goel <deego@gnufans.org> | 7 ;; Maintainer: Jay Belanger <belanger@truman.edu> |
7 ;; Colin Walters <walters@debian.org> | |
8 | 8 |
9 ;; This file is part of GNU Emacs. | 9 ;; This file is part of GNU Emacs. |
10 | 10 |
11 ;; GNU Emacs is distributed in the hope that it will be useful, | 11 ;; GNU Emacs is distributed in the hope that it will be useful, |
12 ;; but WITHOUT ANY WARRANTY. No author or distributor | 12 ;; but WITHOUT ANY WARRANTY. No author or distributor |
26 ;;; Commentary: | 26 ;;; Commentary: |
27 | 27 |
28 ;;; Code: | 28 ;;; Code: |
29 | 29 |
30 ;; This file is autoloaded from calc-ext.el. | 30 ;; This file is autoloaded from calc-ext.el. |
31 | |
31 (require 'calc-ext) | 32 (require 'calc-ext) |
32 | |
33 (require 'calc-macs) | 33 (require 'calc-macs) |
34 | 34 |
35 (defun calc-Need-calc-arith () nil) | 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)) | |
41 | |
42 (defvar math-nonscalar-functions '(vec calcFunc-idn calcFunc-diag | |
43 calcFunc-cvec calcFunc-index | |
44 calcFunc-trn | |
45 | calcFunc-append | |
46 calcFunc-cons calcFunc-rcons | |
47 calcFunc-tail calcFunc-rhead)) | |
48 | |
49 (defvar math-scalar-if-args-functions '(+ - * / neg)) | |
50 | |
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)) | |
59 | |
60 (defvar math-positive-functions '()) | |
61 | |
62 (defvar math-nonnegative-functions '(calcFunc-cnorm calcFunc-rnorm | |
63 calcFunc-vlen calcFunc-vcount)) | |
64 | |
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 | |
70 calcFunc-lnot | |
71 calcFunc-max calcFunc-min)) | |
72 | |
73 (defvar math-real-if-arg-functions '(calcFunc-sin calcFunc-cos | |
74 calcFunc-tan calcFunc-sec | |
75 calcFunc-csc calcFunc-cot | |
76 calcFunc-arctan | |
77 calcFunc-sinh calcFunc-cosh | |
78 calcFunc-tanh calcFunc-sech | |
79 calcFunc-csch calcFunc-coth | |
80 calcFunc-exp | |
81 calcFunc-gamma calcFunc-fact)) | |
82 | |
83 (defvar math-integer-functions '(calcFunc-idiv | |
84 calcFunc-isqrt calcFunc-ilog | |
85 calcFunc-vlen calcFunc-vcount)) | |
86 | |
87 (defvar math-num-integer-functions '()) | |
88 | |
89 (defvar math-rounding-functions '(calcFunc-floor | |
90 calcFunc-ceil | |
91 calcFunc-round calcFunc-trunc | |
92 calcFunc-rounde calcFunc-roundu)) | |
93 | |
94 (defvar math-float-rounding-functions '(calcFunc-ffloor | |
95 calcFunc-fceil | |
96 calcFunc-fround calcFunc-ftrunc | |
97 calcFunc-frounde calcFunc-froundu)) | |
98 | |
99 (defvar math-integer-if-args-functions '(+ - * % neg calcFunc-abs | |
100 calcFunc-min calcFunc-max | |
101 calcFunc-choose calcFunc-perm)) | |
36 | 102 |
37 | 103 |
38 ;;; Arithmetic. | 104 ;;; Arithmetic. |
39 | 105 |
40 (defun calc-min (arg) | 106 (defun calc-min (arg) |
161 ;;; Math-decls-cache is an a-list where each entry is a list of the form: | 227 ;;; Math-decls-cache is an a-list where each entry is a list of the form: |
162 ;;; (VAR TYPES RANGE) | 228 ;;; (VAR TYPES RANGE) |
163 ;;; where VAR is a variable name (with var- prefix) or function name; | 229 ;;; where VAR is a variable name (with var- prefix) or function name; |
164 ;;; TYPES is a list of type symbols (any, int, frac, ...) | 230 ;;; TYPES is a list of type symbols (any, int, frac, ...) |
165 ;;; RANGE is a sorted vector of intervals describing the range. | 231 ;;; RANGE is a sorted vector of intervals describing the range. |
232 | |
233 (defvar math-super-types | |
234 '((int numint rat real number) | |
235 (numint real number) | |
236 (frac rat real number) | |
237 (rat real number) | |
238 (float real number) | |
239 (real number) | |
240 (number) | |
241 (scalar) | |
242 (sqmatrix matrix vector) | |
243 (matrix vector) | |
244 (vector) | |
245 (const))) | |
166 | 246 |
167 (defun math-setup-declarations () | 247 (defun math-setup-declarations () |
168 (or (eq math-decls-cache-tag (calc-var-value 'var-Decls)) | 248 (or (eq math-decls-cache-tag (calc-var-value 'var-Decls)) |
169 (let ((p (calc-var-value 'var-Decls)) | 249 (let ((p (calc-var-value 'var-Decls)) |
170 vec type range) | 250 vec type range) |
212 type) | 292 type) |
213 math-decls-cache))))) | 293 math-decls-cache))))) |
214 (error nil))))) | 294 (error nil))))) |
215 (setq math-decls-all (assq 'var-All math-decls-cache))))) | 295 (setq math-decls-all (assq 'var-All math-decls-cache))))) |
216 | 296 |
217 (defvar math-super-types | |
218 '((int numint rat real number) | |
219 (numint real number) | |
220 (frac rat real number) | |
221 (rat real number) | |
222 (float real number) | |
223 (real number) | |
224 (number) | |
225 (scalar) | |
226 (matrix vector) | |
227 (vector) | |
228 (const))) | |
229 | |
230 (defun math-known-scalarp (a &optional assume-scalar) | 297 (defun math-known-scalarp (a &optional assume-scalar) |
231 (math-setup-declarations) | 298 (math-setup-declarations) |
232 (if (if calc-matrix-mode | 299 (if (if calc-matrix-mode |
233 (eq calc-matrix-mode 'scalar) | 300 (eq calc-matrix-mode 'scalar) |
234 assume-scalar) | 301 assume-scalar) |
236 (math-check-known-scalarp a))) | 303 (math-check-known-scalarp a))) |
237 | 304 |
238 (defun math-known-matrixp (a) | 305 (defun math-known-matrixp (a) |
239 (and (not (Math-scalarp a)) | 306 (and (not (Math-scalarp a)) |
240 (not (math-known-scalarp a t)))) | 307 (not (math-known-scalarp a t)))) |
308 | |
309 (defun math-known-square-matrixp (a) | |
310 (and (math-known-matrixp a) | |
311 (math-check-known-square-matrixp a))) | |
241 | 312 |
242 ;;; Try to prove that A is a scalar (i.e., a non-vector). | 313 ;;; Try to prove that A is a scalar (i.e., a non-vector). |
243 (defun math-check-known-scalarp (a) | 314 (defun math-check-known-scalarp (a) |
244 (cond ((Math-objectp a) t) | 315 (cond ((Math-objectp a) t) |
245 ((memq (car a) math-scalar-functions) | 316 ((memq (car a) math-scalar-functions) |
255 ((math-const-var a) t) | 326 ((math-const-var a) t) |
256 (t | 327 (t |
257 (let ((decl (if (eq (car a) 'var) | 328 (let ((decl (if (eq (car a) 'var) |
258 (or (assq (nth 2 a) math-decls-cache) | 329 (or (assq (nth 2 a) math-decls-cache) |
259 math-decls-all) | 330 math-decls-all) |
260 (assq (car a) math-decls-cache)))) | 331 (assq (car a) math-decls-cache))) |
261 (memq 'scalar (nth 1 decl)))))) | 332 val) |
333 (cond | |
334 ((memq 'scalar (nth 1 decl)) | |
335 t) | |
336 ((and (eq (car a) 'var) | |
337 (boundp (nth 2 a)) | |
338 (setq val (symbol-value (nth 2 a)))) | |
339 (math-check-known-scalarp val)) | |
340 (t | |
341 nil)))))) | |
262 | 342 |
263 ;;; Try to prove that A is *not* a scalar. | 343 ;;; Try to prove that A is *not* a scalar. |
264 (defun math-check-known-matrixp (a) | 344 (defun math-check-known-matrixp (a) |
265 (cond ((Math-objectp a) nil) | 345 (cond ((Math-objectp a) nil) |
266 ((memq (car a) math-nonscalar-functions) | 346 ((memq (car a) math-nonscalar-functions) |
274 ((math-const-var a) nil) | 354 ((math-const-var a) nil) |
275 (t | 355 (t |
276 (let ((decl (if (eq (car a) 'var) | 356 (let ((decl (if (eq (car a) 'var) |
277 (or (assq (nth 2 a) math-decls-cache) | 357 (or (assq (nth 2 a) math-decls-cache) |
278 math-decls-all) | 358 math-decls-all) |
279 (assq (car a) math-decls-cache)))) | 359 (assq (car a) math-decls-cache))) |
280 (memq 'vector (nth 1 decl)))))) | 360 val) |
281 | 361 (cond |
362 ((memq 'matrix (nth 1 decl)) | |
363 t) | |
364 ((and (eq (car a) 'var) | |
365 (boundp (nth 2 a)) | |
366 (setq val (symbol-value (nth 2 a)))) | |
367 (math-check-known-matrixp val)) | |
368 (t | |
369 nil)))))) | |
370 | |
371 ;;; Given that A is a matrix, try to prove that it is a square matrix. | |
372 (defun math-check-known-square-matrixp (a) | |
373 (cond ((math-square-matrixp a) | |
374 t) | |
375 ((eq (car-safe a) '^) | |
376 (math-check-known-square-matrixp (nth 1 a))) | |
377 ((or | |
378 (eq (car-safe a) '*) | |
379 (eq (car-safe a) '+) | |
380 (eq (car-safe a) '-)) | |
381 (and | |
382 (math-check-known-square-matrixp (nth 1 a)) | |
383 (math-check-known-square-matrixp (nth 2 a)))) | |
384 (t | |
385 (let ((decl (if (eq (car a) 'var) | |
386 (or (assq (nth 2 a) math-decls-cache) | |
387 math-decls-all) | |
388 (assq (car a) math-decls-cache))) | |
389 val) | |
390 (cond | |
391 ((memq 'sqmatrix (nth 1 decl)) | |
392 t) | |
393 ((and (eq (car a) 'var) | |
394 (boundp (nth 2 a)) | |
395 (setq val (symbol-value (nth 2 a)))) | |
396 (math-check-known-square-matrixp val)) | |
397 ((and (or | |
398 (integerp calc-matrix-mode) | |
399 (eq calc-matrix-mode 'sqmatrix)) | |
400 (eq (car-safe a) 'var)) | |
401 t) | |
402 ((memq 'matrix (nth 1 decl)) | |
403 nil) | |
404 (t | |
405 nil)))))) | |
282 | 406 |
283 ;;; Try to prove that A is a real (i.e., not complex). | 407 ;;; Try to prove that A is a real (i.e., not complex). |
284 (defun math-known-realp (a) | 408 (defun math-known-realp (a) |
285 (< (math-possible-signs a) 8)) | 409 (< (math-possible-signs a) 8)) |
286 | 410 |
324 (if origin (setq a (math-sub a origin))) | 448 (if origin (setq a (math-sub a origin))) |
325 (cond ((Math-posp a) 4) | 449 (cond ((Math-posp a) 4) |
326 ((Math-negp a) 1) | 450 ((Math-negp a) 1) |
327 ((Math-zerop a) 2) | 451 ((Math-zerop a) 2) |
328 ((eq (car a) 'intv) | 452 ((eq (car a) 'intv) |
329 (cond ((Math-zerop (nth 2 a)) 6) | 453 (cond |
330 ((Math-zerop (nth 3 a)) 3) | 454 ((math-known-posp (nth 2 a)) 4) |
331 (t 7))) | 455 ((math-known-negp (nth 3 a)) 1) |
456 ((Math-zerop (nth 2 a)) 6) | |
457 ((Math-zerop (nth 3 a)) 3) | |
458 (t 7))) | |
332 ((eq (car a) 'sdev) | 459 ((eq (car a) 'sdev) |
333 (if (math-known-realp (nth 1 a)) 7 15)) | 460 (if (math-known-realp (nth 1 a)) 7 15)) |
334 (t 8))) | 461 (t 8))) |
335 ((memq (car a) '(+ -)) | 462 ((memq (car a) '(+ -)) |
336 (cond ((Math-realp (nth 1 a)) | 463 (cond ((Math-realp (nth 1 a)) |
817 (if (math-known-scalarp a) 1 | 944 (if (math-known-scalarp a) 1 |
818 (if (math-known-matrixp a) 0 | 945 (if (math-known-matrixp a) 0 |
819 (math-reject-arg a 'objectp 'quiet)))) | 946 (math-reject-arg a 'objectp 'quiet)))) |
820 | 947 |
821 | 948 |
822 ;;; The following lists are not exhaustive. | |
823 (defvar math-scalar-functions '(calcFunc-det | |
824 calcFunc-cnorm calcFunc-rnorm | |
825 calcFunc-vlen calcFunc-vcount | |
826 calcFunc-vsum calcFunc-vprod | |
827 calcFunc-vmin calcFunc-vmax)) | |
828 | |
829 (defvar math-nonscalar-functions '(vec calcFunc-idn calcFunc-diag | |
830 calcFunc-cvec calcFunc-index | |
831 calcFunc-trn | |
832 | calcFunc-append | |
833 calcFunc-cons calcFunc-rcons | |
834 calcFunc-tail calcFunc-rhead)) | |
835 | |
836 (defvar math-scalar-if-args-functions '(+ - * / neg)) | |
837 | |
838 (defvar math-real-functions '(calcFunc-arg | |
839 calcFunc-re calcFunc-im | |
840 calcFunc-floor calcFunc-ceil | |
841 calcFunc-trunc calcFunc-round | |
842 calcFunc-rounde calcFunc-roundu | |
843 calcFunc-ffloor calcFunc-fceil | |
844 calcFunc-ftrunc calcFunc-fround | |
845 calcFunc-frounde calcFunc-froundu)) | |
846 | |
847 (defvar math-positive-functions '()) | |
848 | |
849 (defvar math-nonnegative-functions '(calcFunc-cnorm calcFunc-rnorm | |
850 calcFunc-vlen calcFunc-vcount)) | |
851 | |
852 (defvar math-real-scalar-functions '(% calcFunc-idiv calcFunc-abs | |
853 calcFunc-choose calcFunc-perm | |
854 calcFunc-eq calcFunc-neq | |
855 calcFunc-lt calcFunc-gt | |
856 calcFunc-leq calcFunc-geq | |
857 calcFunc-lnot | |
858 calcFunc-max calcFunc-min)) | |
859 | |
860 (defvar math-real-if-arg-functions '(calcFunc-sin calcFunc-cos | |
861 calcFunc-tan calcFunc-arctan | |
862 calcFunc-sinh calcFunc-cosh | |
863 calcFunc-tanh calcFunc-exp | |
864 calcFunc-gamma calcFunc-fact)) | |
865 | |
866 (defvar math-integer-functions '(calcFunc-idiv | |
867 calcFunc-isqrt calcFunc-ilog | |
868 calcFunc-vlen calcFunc-vcount)) | |
869 | |
870 (defvar math-num-integer-functions '()) | |
871 | |
872 (defvar math-rounding-functions '(calcFunc-floor | |
873 calcFunc-ceil | |
874 calcFunc-round calcFunc-trunc | |
875 calcFunc-rounde calcFunc-roundu)) | |
876 | |
877 (defvar math-float-rounding-functions '(calcFunc-ffloor | |
878 calcFunc-fceil | |
879 calcFunc-fround calcFunc-ftrunc | |
880 calcFunc-frounde calcFunc-froundu)) | |
881 | |
882 (defvar math-integer-if-args-functions '(+ - * % neg calcFunc-abs | |
883 calcFunc-min calcFunc-max | |
884 calcFunc-choose calcFunc-perm)) | |
885 | |
886 | |
887 ;;;; Arithmetic. | 949 ;;;; Arithmetic. |
888 | 950 |
889 (defsubst calcFunc-neg (a) | 951 (defsubst calcFunc-neg (a) |
890 (math-normalize (list 'neg a))) | 952 (math-normalize (list 'neg a))) |
891 | 953 |
1329 (math-div b (math-normalize | 1391 (math-div b (math-normalize |
1330 (list '^ (nth 1 a) (math-neg (nth 2 a)))))) | 1392 (list '^ (nth 1 a) (math-neg (nth 2 a)))))) |
1331 (and (eq (car-safe b) '^) | 1393 (and (eq (car-safe b) '^) |
1332 (Math-looks-negp (nth 2 b)) | 1394 (Math-looks-negp (nth 2 b)) |
1333 (not (and (eq (car-safe a) '^) (Math-looks-negp (nth 2 a)))) | 1395 (not (and (eq (car-safe a) '^) (Math-looks-negp (nth 2 a)))) |
1396 (not (math-known-matrixp (nth 1 b))) | |
1334 (math-div a (math-normalize | 1397 (math-div a (math-normalize |
1335 (list '^ (nth 1 b) (math-neg (nth 2 b)))))) | 1398 (list '^ (nth 1 b) (math-neg (nth 2 b)))))) |
1336 (and (eq (car-safe a) '/) | 1399 (and (eq (car-safe a) '/) |
1337 (or (math-known-scalarp a t) (math-known-scalarp b t)) | 1400 (or (math-known-scalarp a t) (math-known-scalarp b t)) |
1338 (let ((temp (math-combine-prod (nth 2 a) b t nil t))) | 1401 (let ((temp (math-combine-prod (nth 2 a) b t nil t))) |
1370 (= (length b) 2) | 1433 (= (length b) 2) |
1371 (or (and (math-known-scalarp a) | 1434 (or (and (math-known-scalarp a) |
1372 (list 'calcFunc-idn (math-mul a (nth 1 b)))) | 1435 (list 'calcFunc-idn (math-mul a (nth 1 b)))) |
1373 (and (math-known-matrixp a) | 1436 (and (math-known-matrixp a) |
1374 (math-mul a (nth 1 b))))) | 1437 (math-mul a (nth 1 b))))) |
1438 (and (math-identity-matrix-p a t) | |
1439 (or (and (eq (car-safe b) 'calcFunc-idn) | |
1440 (= (length b) 2) | |
1441 (list 'calcFunc-idn (math-mul | |
1442 (nth 1 (nth 1 a)) | |
1443 (nth 1 b)) | |
1444 (1- (length a)))) | |
1445 (and (math-known-scalarp b) | |
1446 (list 'calcFunc-idn (math-mul | |
1447 (nth 1 (nth 1 a)) b) | |
1448 (1- (length a)))) | |
1449 (and (math-known-matrixp b) | |
1450 (math-mul (nth 1 (nth 1 a)) b)))) | |
1451 (and (math-identity-matrix-p b t) | |
1452 (or (and (eq (car-safe a) 'calcFunc-idn) | |
1453 (= (length a) 2) | |
1454 (list 'calcFunc-idn (math-mul (nth 1 a) | |
1455 (nth 1 (nth 1 b))) | |
1456 (1- (length b)))) | |
1457 (and (math-known-scalarp a) | |
1458 (list 'calcFunc-idn (math-mul a (nth 1 (nth 1 b))) | |
1459 (1- (length b)))) | |
1460 (and (math-known-matrixp a) | |
1461 (math-mul a (nth 1 (nth 1 b)))))) | |
1375 (and (math-looks-negp b) | 1462 (and (math-looks-negp b) |
1376 (math-mul (math-neg a) (math-neg b))) | 1463 (math-mul (math-neg a) (math-neg b))) |
1377 (and (eq (car-safe b) '-) | 1464 (and (eq (car-safe b) '-) |
1378 (math-looks-negp a) | 1465 (math-looks-negp a) |
1379 (math-mul (math-neg a) (math-neg b))) | 1466 (math-mul (math-neg a) (math-neg b))) |
1604 (memq calc-infinite-mode '(1 -1))) | 1691 (memq calc-infinite-mode '(1 -1))) |
1605 (nth 3 b) '(var inf var-inf))) | 1692 (nth 3 b) '(var inf var-inf))) |
1606 (math-reject-arg b "*Division by zero")) | 1693 (math-reject-arg b "*Division by zero")) |
1607 a)))) | 1694 a)))) |
1608 | 1695 |
1696 ;; For math-div-symb-fancy | |
1697 (defvar math-trig-inverses | |
1698 '((calcFunc-sin . calcFunc-csc) | |
1699 (calcFunc-cos . calcFunc-sec) | |
1700 (calcFunc-tan . calcFunc-cot) | |
1701 (calcFunc-sec . calcFunc-cos) | |
1702 (calcFunc-csc . calcFunc-sin) | |
1703 (calcFunc-cot . calcFunc-tan) | |
1704 (calcFunc-sinh . calcFunc-csch) | |
1705 (calcFunc-cosh . calcFunc-sech) | |
1706 (calcFunc-tanh . calcFunc-coth) | |
1707 (calcFunc-sech . calcFunc-cosh) | |
1708 (calcFunc-csch . calcFunc-sinh) | |
1709 (calcFunc-coth . calcFunc-tanh))) | |
1710 | |
1711 (defvar math-div-trig) | |
1712 (defvar math-div-non-trig) | |
1713 | |
1714 (defun math-div-new-trig (tr) | |
1715 (if math-div-trig | |
1716 (setq math-div-trig | |
1717 (list '* tr math-div-trig)) | |
1718 (setq math-div-trig tr))) | |
1719 | |
1720 (defun math-div-new-non-trig (ntr) | |
1721 (if math-div-non-trig | |
1722 (setq math-div-non-trig | |
1723 (list '* ntr math-div-non-trig)) | |
1724 (setq math-div-non-trig ntr))) | |
1725 | |
1726 (defun math-div-isolate-trig (expr) | |
1727 (if (eq (car-safe expr) '*) | |
1728 (progn | |
1729 (math-div-isolate-trig-term (nth 1 expr)) | |
1730 (math-div-isolate-trig (nth 2 expr))) | |
1731 (math-div-isolate-trig-term expr))) | |
1732 | |
1733 (defun math-div-isolate-trig-term (term) | |
1734 (let ((fn (assoc (car-safe term) math-trig-inverses))) | |
1735 (if fn | |
1736 (math-div-new-trig | |
1737 (cons (cdr fn) (cdr term))) | |
1738 (math-div-new-non-trig term)))) | |
1739 | |
1609 (defun math-div-symb-fancy (a b) | 1740 (defun math-div-symb-fancy (a b) |
1610 (or (and math-simplify-only | 1741 (or (and (math-known-matrixp b) |
1742 (math-mul a (math-pow b -1))) | |
1743 (and math-simplify-only | |
1611 (not (equal a math-simplify-only)) | 1744 (not (equal a math-simplify-only)) |
1612 (list '/ a b)) | 1745 (list '/ a b)) |
1613 (and (Math-equal-int b 1) a) | 1746 (and (Math-equal-int b 1) a) |
1614 (and (Math-equal-int b -1) (math-neg a)) | 1747 (and (Math-equal-int b -1) (math-neg a)) |
1615 (and (Math-vectorp a) (math-known-scalarp b) | 1748 (and (Math-vectorp a) (math-known-scalarp b) |
1662 (= (length b) 2) | 1795 (= (length b) 2) |
1663 (or (and (math-known-scalarp a) | 1796 (or (and (math-known-scalarp a) |
1664 (list 'calcFunc-idn (math-div a (nth 1 b)))) | 1797 (list 'calcFunc-idn (math-div a (nth 1 b)))) |
1665 (and (math-known-matrixp a) | 1798 (and (math-known-matrixp a) |
1666 (math-div a (nth 1 b))))) | 1799 (math-div a (nth 1 b))))) |
1800 (and math-simplifying | |
1801 (let ((math-div-trig nil) | |
1802 (math-div-non-trig nil)) | |
1803 (math-div-isolate-trig b) | |
1804 (if math-div-trig | |
1805 (if math-div-non-trig | |
1806 (math-div (math-mul a math-div-trig) math-div-non-trig) | |
1807 (math-mul a math-div-trig)) | |
1808 nil))) | |
1667 (if (and calc-matrix-mode | 1809 (if (and calc-matrix-mode |
1668 (or (math-known-matrixp a) (math-known-matrixp b))) | 1810 (or (math-known-matrixp a) (math-known-matrixp b))) |
1669 (math-combine-prod a b nil t nil) | 1811 (math-combine-prod a b nil t nil) |
1670 (if (eq (car-safe a) '*) | 1812 (if (eq (car-safe a) '*) |
1671 (if (eq (car-safe b) '*) | 1813 (if (eq (car-safe b) '*) |
1710 b | 1852 b |
1711 (let ((calc-infinite-mode 1)) | 1853 (let ((calc-infinite-mode 1)) |
1712 (math-mul-zero b a)))) | 1854 (math-mul-zero b a)))) |
1713 (list '/ a b))) | 1855 (list '/ a b))) |
1714 | 1856 |
1857 ;;; Division from the left. | |
1858 (defun calcFunc-ldiv (a b) | |
1859 (if (math-known-scalarp a) | |
1860 (math-div b a) | |
1861 (math-mul (math-pow a -1) b))) | |
1715 | 1862 |
1716 (defun calcFunc-mod (a b) | 1863 (defun calcFunc-mod (a b) |
1717 (math-normalize (list '% a b))) | 1864 (math-normalize (list '% a b))) |
1718 | 1865 |
1719 (defun math-mod-fancy (a b) | 1866 (defun math-mod-fancy (a b) |
1740 | 1887 |
1741 (defun calcFunc-pow (a b) | 1888 (defun calcFunc-pow (a b) |
1742 (math-normalize (list '^ a b))) | 1889 (math-normalize (list '^ a b))) |
1743 | 1890 |
1744 (defun math-pow-of-zero (a b) | 1891 (defun math-pow-of-zero (a b) |
1745 (if (Math-zerop b) | 1892 "Raise A to the power of B, where A is a form of zero." |
1746 (if calc-infinite-mode | 1893 (if (math-floatp b) (setq a (math-float a))) |
1747 '(var nan var-nan) | 1894 (cond |
1748 (math-reject-arg (list '^ a b) "*Indeterminate form")) | 1895 ;; 0^0 = 1 |
1749 (if (math-floatp b) (setq a (math-float a))) | 1896 ((eq b 0) |
1750 (if (math-posp b) | 1897 1) |
1751 a | 1898 ;; 0^0.0, etc., are undetermined |
1752 (if (math-negp b) | 1899 ((Math-zerop b) |
1753 (math-div 1 a) | 1900 (if calc-infinite-mode |
1754 (if (math-infinitep b) | 1901 '(var nan var-nan) |
1755 '(var nan var-nan) | 1902 (math-reject-arg (list '^ a b) "*Indeterminate form"))) |
1756 (if (and (eq (car b) 'intv) (math-intv-constp b) | 1903 ;; 0^positive = 0 |
1757 calc-infinite-mode) | 1904 ((math-known-posp b) |
1758 '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) | 1905 a) |
1759 (if (math-objectp b) | 1906 ;; 0^negative is undefined (let math-div handle it) |
1760 (list '^ a b) | 1907 ((math-known-negp b) |
1761 a))))))) | 1908 (math-div 1 a)) |
1909 ;; 0^infinity is undefined | |
1910 ((math-infinitep b) | |
1911 '(var nan var-nan)) | |
1912 ;; Some intervals | |
1913 ((and (eq (car b) 'intv) | |
1914 calc-infinite-mode | |
1915 (math-negp (nth 2 b)) | |
1916 (math-posp (nth 3 b))) | |
1917 '(intv 3 (neg (var inf var-inf)) (var inf var-inf))) | |
1918 ;; If none of the above, leave it alone. | |
1919 (t | |
1920 (list '^ a b)))) | |
1762 | 1921 |
1763 (defun math-pow-zero (a b) | 1922 (defun math-pow-zero (a b) |
1764 (if (eq (car-safe a) 'mod) | 1923 (if (eq (car-safe a) 'mod) |
1765 (math-make-mod 1 (nth 2 a)) | 1924 (math-make-mod 1 (nth 2 a)) |
1766 (if (math-known-matrixp a) | 1925 (if (math-known-matrixp a) |
1798 (not (Math-objectp b))) | 1957 (not (Math-objectp b))) |
1799 (let (temp) | 1958 (let (temp) |
1800 (cond ((and math-simplify-only | 1959 (cond ((and math-simplify-only |
1801 (not (equal a math-simplify-only))) | 1960 (not (equal a math-simplify-only))) |
1802 (list '^ a b)) | 1961 (list '^ a b)) |
1962 ((and (eq (car-safe a) '*) | |
1963 (or | |
1964 (and | |
1965 (math-known-matrixp (nth 1 a)) | |
1966 (math-known-matrixp (nth 2 a))) | |
1967 (and | |
1968 calc-matrix-mode | |
1969 (not (eq calc-matrix-mode 'scalar)) | |
1970 (and (not (math-known-scalarp (nth 1 a))) | |
1971 (not (math-known-scalarp (nth 2 a))))))) | |
1972 (if (and (= b -1) | |
1973 (math-known-square-matrixp (nth 1 a)) | |
1974 (math-known-square-matrixp (nth 2 a))) | |
1975 (math-mul (math-pow-fancy (nth 2 a) -1) | |
1976 (math-pow-fancy (nth 1 a) -1)) | |
1977 (list '^ a b))) | |
1803 ((and (eq (car-safe a) '*) | 1978 ((and (eq (car-safe a) '*) |
1804 (or (math-known-num-integerp b) | 1979 (or (math-known-num-integerp b) |
1805 (math-known-nonnegp (nth 1 a)) | 1980 (math-known-nonnegp (nth 1 a)) |
1806 (math-known-nonnegp (nth 2 a)))) | 1981 (math-known-nonnegp (nth 2 a)))) |
1807 (math-mul (math-pow (nth 1 a) b) | 1982 (math-mul (math-pow (nth 1 a) b) |
2183 (and func (cons (cdr func) (cdr a))))) | 2358 (and func (cons (cdr func) (cdr a))))) |
2184 (t (math-reject-arg a 'objectp)))) | 2359 (t (math-reject-arg a 'objectp)))) |
2185 | 2360 |
2186 (defalias 'calcFunc-float 'math-float) | 2361 (defalias 'calcFunc-float 'math-float) |
2187 | 2362 |
2363 ;; The variable math-trunc-prec is local to math-trunc in calc-misc.el, | |
2364 ;; but used by math-trunc-fancy which is called by math-trunc. | |
2365 (defvar math-trunc-prec) | |
2366 | |
2188 (defun math-trunc-fancy (a) | 2367 (defun math-trunc-fancy (a) |
2189 (cond ((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a))) | 2368 (cond ((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a))) |
2190 ((eq (car a) 'cplx) (math-trunc (nth 1 a))) | 2369 ((eq (car a) 'cplx) (math-trunc (nth 1 a))) |
2191 ((eq (car a) 'polar) (math-trunc (math-complex a))) | 2370 ((eq (car a) 'polar) (math-trunc (math-complex a))) |
2192 ((eq (car a) 'hms) (list 'hms (nth 1 a) 0 0)) | 2371 ((eq (car a) 'hms) (list 'hms (nth 1 a) 0 0)) |
2212 (memq (nth 1 a) '(0 2))) | 2391 (memq (nth 1 a) '(0 2))) |
2213 (math-add (math-trunc (nth 3 a)) -1) | 2392 (math-add (math-trunc (nth 3 a)) -1) |
2214 (math-trunc (nth 3 a))))) | 2393 (math-trunc (nth 3 a))))) |
2215 ((math-provably-integerp a) a) | 2394 ((math-provably-integerp a) a) |
2216 ((Math-vectorp a) | 2395 ((Math-vectorp a) |
2217 (math-map-vec (function (lambda (x) (math-trunc x prec))) a)) | 2396 (math-map-vec (function (lambda (x) (math-trunc x math-trunc-prec))) a)) |
2218 ((math-infinitep a) | 2397 ((math-infinitep a) |
2219 (if (or (math-posp a) (math-negp a)) | 2398 (if (or (math-posp a) (math-negp a)) |
2220 a | 2399 a |
2221 '(var nan var-nan))) | 2400 '(var nan var-nan))) |
2222 ((math-to-integer a)) | 2401 ((math-to-integer a)) |
2248 (if (and (Math-messy-integerp a) | 2427 (if (and (Math-messy-integerp a) |
2249 (or (not prec) (and (integerp prec) | 2428 (or (not prec) (and (integerp prec) |
2250 (<= prec 0)))) | 2429 (<= prec 0)))) |
2251 a | 2430 a |
2252 (math-float (math-trunc a prec)))) | 2431 (math-float (math-trunc a prec)))) |
2432 | |
2433 ;; The variable math-floor-prec is local to math-floor in calc-misc.el, | |
2434 ;; but used by math-floor-fancy which is called by math-floor. | |
2435 (defvar math-floor-prec) | |
2253 | 2436 |
2254 (defun math-floor-fancy (a) | 2437 (defun math-floor-fancy (a) |
2255 (cond ((math-provably-integerp a) a) | 2438 (cond ((math-provably-integerp a) a) |
2256 ((eq (car a) 'hms) | 2439 ((eq (car a) 'hms) |
2257 (if (or (math-posp a) | 2440 (if (or (math-posp a) |
2271 (if (and (Math-num-integerp (nth 3 a)) | 2454 (if (and (Math-num-integerp (nth 3 a)) |
2272 (memq (nth 1 a) '(0 2))) | 2455 (memq (nth 1 a) '(0 2))) |
2273 (math-add (math-floor (nth 3 a)) -1) | 2456 (math-add (math-floor (nth 3 a)) -1) |
2274 (math-floor (nth 3 a))))) | 2457 (math-floor (nth 3 a))))) |
2275 ((Math-vectorp a) | 2458 ((Math-vectorp a) |
2276 (math-map-vec (function (lambda (x) (math-floor x prec))) a)) | 2459 (math-map-vec (function (lambda (x) (math-floor x math-floor-prec))) a)) |
2277 ((math-infinitep a) | 2460 ((math-infinitep a) |
2278 (if (or (math-posp a) (math-negp a)) | 2461 (if (or (math-posp a) (math-negp a)) |
2279 a | 2462 a |
2280 '(var nan var-nan))) | 2463 '(var nan var-nan))) |
2281 ((math-to-integer a)) | 2464 ((math-to-integer a)) |
2627 (math-add a b))) | 2810 (math-add a b))) |
2628 | 2811 |
2629 (defvar math-combine-prod-e '(var e var-e)) | 2812 (defvar math-combine-prod-e '(var e var-e)) |
2630 | 2813 |
2631 ;;; The following is expanded out four ways for speed. | 2814 ;;; The following is expanded out four ways for speed. |
2815 | |
2816 ;; math-unit-prefixes is defined in calc-units.el, | |
2817 ;; but used here. | |
2818 (defvar math-unit-prefixes) | |
2819 | |
2632 (defun math-combine-prod (a b inva invb scalar-okay) | 2820 (defun math-combine-prod (a b inva invb scalar-okay) |
2633 (cond | 2821 (cond |
2634 ((or (and inva (Math-zerop a)) | 2822 ((or (and inva (Math-zerop a)) |
2635 (and invb (Math-zerop b))) | 2823 (and invb (Math-zerop b))) |
2636 nil) | 2824 nil) |
2644 (math-mul (math-pow (nth 1 a) (math-neg (nth 2 a))) b)) | 2832 (math-mul (math-pow (nth 1 a) (math-neg (nth 2 a))) b)) |
2645 ((and (eq (car-safe b) '^) | 2833 ((and (eq (car-safe b) '^) |
2646 invb | 2834 invb |
2647 (math-looks-negp (nth 2 b))) | 2835 (math-looks-negp (nth 2 b))) |
2648 (math-mul a (math-pow (nth 1 b) (math-neg (nth 2 b))))) | 2836 (math-mul a (math-pow (nth 1 b) (math-neg (nth 2 b))))) |
2837 ((and math-simplifying | |
2838 (math-combine-prod-trig a b))) | |
2649 (t (let ((apow 1) (bpow 1)) | 2839 (t (let ((apow 1) (bpow 1)) |
2650 (and (consp a) | 2840 (and (consp a) |
2651 (cond ((and (eq (car a) '^) | 2841 (cond ((and (eq (car a) '^) |
2652 (or math-simplifying | 2842 (or math-simplifying |
2653 (Math-numberp (nth 2 a)))) | 2843 (Math-numberp (nth 2 a)))) |
2741 (setq a (math-mul a b)) | 2931 (setq a (math-mul a b)) |
2742 (condition-case err | 2932 (condition-case err |
2743 (math-pow a apow) | 2933 (math-pow a apow) |
2744 (inexact-result (list '^ a apow))))))))))) | 2934 (inexact-result (list '^ a apow))))))))))) |
2745 | 2935 |
2936 (defun math-combine-prod-trig (a b) | |
2937 (cond | |
2938 ((and (eq (car-safe a) 'calcFunc-sin) | |
2939 (eq (car-safe b) 'calcFunc-csc) | |
2940 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2941 1) | |
2942 ((and (eq (car-safe a) 'calcFunc-sin) | |
2943 (eq (car-safe b) 'calcFunc-sec) | |
2944 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2945 (cons 'calcFunc-tan (cdr a))) | |
2946 ((and (eq (car-safe a) 'calcFunc-sin) | |
2947 (eq (car-safe b) 'calcFunc-cot) | |
2948 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2949 (cons 'calcFunc-cos (cdr a))) | |
2950 ((and (eq (car-safe a) 'calcFunc-cos) | |
2951 (eq (car-safe b) 'calcFunc-sec) | |
2952 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2953 1) | |
2954 ((and (eq (car-safe a) 'calcFunc-cos) | |
2955 (eq (car-safe b) 'calcFunc-csc) | |
2956 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2957 (cons 'calcFunc-cot (cdr a))) | |
2958 ((and (eq (car-safe a) 'calcFunc-cos) | |
2959 (eq (car-safe b) 'calcFunc-tan) | |
2960 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2961 (cons 'calcFunc-sin (cdr a))) | |
2962 ((and (eq (car-safe a) 'calcFunc-tan) | |
2963 (eq (car-safe b) 'calcFunc-cot) | |
2964 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2965 1) | |
2966 ((and (eq (car-safe a) 'calcFunc-tan) | |
2967 (eq (car-safe b) 'calcFunc-csc) | |
2968 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2969 (cons 'calcFunc-sec (cdr a))) | |
2970 ((and (eq (car-safe a) 'calcFunc-sec) | |
2971 (eq (car-safe b) 'calcFunc-cot) | |
2972 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2973 (cons 'calcFunc-csc (cdr a))) | |
2974 ((and (eq (car-safe a) 'calcFunc-sinh) | |
2975 (eq (car-safe b) 'calcFunc-csch) | |
2976 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2977 1) | |
2978 ((and (eq (car-safe a) 'calcFunc-sinh) | |
2979 (eq (car-safe b) 'calcFunc-sech) | |
2980 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2981 (cons 'calcFunc-tanh (cdr a))) | |
2982 ((and (eq (car-safe a) 'calcFunc-sinh) | |
2983 (eq (car-safe b) 'calcFunc-coth) | |
2984 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2985 (cons 'calcFunc-cosh (cdr a))) | |
2986 ((and (eq (car-safe a) 'calcFunc-cosh) | |
2987 (eq (car-safe b) 'calcFunc-sech) | |
2988 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2989 1) | |
2990 ((and (eq (car-safe a) 'calcFunc-cosh) | |
2991 (eq (car-safe b) 'calcFunc-csch) | |
2992 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2993 (cons 'calcFunc-coth (cdr a))) | |
2994 ((and (eq (car-safe a) 'calcFunc-cosh) | |
2995 (eq (car-safe b) 'calcFunc-tanh) | |
2996 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
2997 (cons 'calcFunc-sinh (cdr a))) | |
2998 ((and (eq (car-safe a) 'calcFunc-tanh) | |
2999 (eq (car-safe b) 'calcFunc-coth) | |
3000 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
3001 1) | |
3002 ((and (eq (car-safe a) 'calcFunc-tanh) | |
3003 (eq (car-safe b) 'calcFunc-csch) | |
3004 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
3005 (cons 'calcFunc-sech (cdr a))) | |
3006 ((and (eq (car-safe a) 'calcFunc-sech) | |
3007 (eq (car-safe b) 'calcFunc-coth) | |
3008 (= 0 (math-simplify (math-sub (cdr a) (cdr b))))) | |
3009 (cons 'calcFunc-csch (cdr a))) | |
3010 (t | |
3011 nil))) | |
3012 | |
2746 (defun math-mul-or-div (a b ainv binv) | 3013 (defun math-mul-or-div (a b ainv binv) |
2747 (if (or (Math-vectorp a) (Math-vectorp b)) | 3014 (if (or (Math-vectorp a) (Math-vectorp b)) |
2748 (math-normalize | 3015 (math-normalize |
2749 (if ainv | 3016 (if ainv |
2750 (if binv | 3017 (if binv |
2759 (math-div b a)) | 3026 (math-div b a)) |
2760 (if binv | 3027 (if binv |
2761 (math-div a b) | 3028 (math-div a b) |
2762 (math-mul a b))))) | 3029 (math-mul a b))))) |
2763 | 3030 |
3031 ;; The variable math-com-bterms is local to math-commutative-equal, | |
3032 ;; but is used by math-commutative collect, which is called by | |
3033 ;; math-commutative-equal. | |
3034 (defvar math-com-bterms) | |
3035 | |
2764 (defun math-commutative-equal (a b) | 3036 (defun math-commutative-equal (a b) |
2765 (if (memq (car-safe a) '(+ -)) | 3037 (if (memq (car-safe a) '(+ -)) |
2766 (and (memq (car-safe b) '(+ -)) | 3038 (and (memq (car-safe b) '(+ -)) |
2767 (let ((bterms nil) aterms p) | 3039 (let ((math-com-bterms nil) aterms p) |
2768 (math-commutative-collect b nil) | 3040 (math-commutative-collect b nil) |
2769 (setq aterms bterms bterms nil) | 3041 (setq aterms math-com-bterms math-com-bterms nil) |
2770 (math-commutative-collect a nil) | 3042 (math-commutative-collect a nil) |
2771 (and (= (length aterms) (length bterms)) | 3043 (and (= (length aterms) (length math-com-bterms)) |
2772 (progn | 3044 (progn |
2773 (while (and aterms | 3045 (while (and aterms |
2774 (progn | 3046 (progn |
2775 (setq p bterms) | 3047 (setq p math-com-bterms) |
2776 (while (and p (not (equal (car aterms) | 3048 (while (and p (not (equal (car aterms) |
2777 (car p)))) | 3049 (car p)))) |
2778 (setq p (cdr p))) | 3050 (setq p (cdr p))) |
2779 p)) | 3051 p)) |
2780 (setq bterms (delq (car p) bterms) | 3052 (setq math-com-bterms (delq (car p) math-com-bterms) |
2781 aterms (cdr aterms))) | 3053 aterms (cdr aterms))) |
2782 (not aterms))))) | 3054 (not aterms))))) |
2783 (equal a b))) | 3055 (equal a b))) |
2784 | 3056 |
2785 (defun math-commutative-collect (b neg) | 3057 (defun math-commutative-collect (b neg) |
2789 (math-commutative-collect (nth 2 b) neg)) | 3061 (math-commutative-collect (nth 2 b) neg)) |
2790 (if (eq (car-safe b) '-) | 3062 (if (eq (car-safe b) '-) |
2791 (progn | 3063 (progn |
2792 (math-commutative-collect (nth 1 b) neg) | 3064 (math-commutative-collect (nth 1 b) neg) |
2793 (math-commutative-collect (nth 2 b) (not neg))) | 3065 (math-commutative-collect (nth 2 b) (not neg))) |
2794 (setq bterms (cons (if neg (math-neg b) b) bterms))))) | 3066 (setq math-com-bterms (cons (if neg (math-neg b) b) math-com-bterms))))) |
2795 | 3067 |
3068 (provide 'calc-arith) | |
3069 | |
3070 ;;; arch-tag: 6c396b5b-14c6-40ed-bb2a-7cc2e8111465 | |
2796 ;;; calc-arith.el ends here | 3071 ;;; calc-arith.el ends here |