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