Mercurial > emacs
annotate lisp/calc/calc-math.el @ 41044:4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
`symbol-function'.
Style cleanup; don't put closing parens on their
own line, add "foo.el ends here" to each file, and update
copyright date.
author | Colin Walters <walters@gnu.org> |
---|---|
date | Wed, 14 Nov 2001 09:05:36 +0000 |
parents | 2fb9d407ae73 |
children | fcd507927105 |
rev | line source |
---|---|
40785 | 1 ;; Calculator for GNU Emacs, part II [calc-math.el] |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
2 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
40785 | 3 ;; Written by Dave Gillespie, daveg@synaptics.com. |
4 | |
5 ;; This file is part of GNU Emacs. | |
6 | |
7 ;; GNU Emacs is distributed in the hope that it will be useful, | |
8 ;; but WITHOUT ANY WARRANTY. No author or distributor | |
9 ;; accepts responsibility to anyone for the consequences of using it | |
10 ;; or for whether it serves any particular purpose or works at all, | |
11 ;; unless he says so in writing. Refer to the GNU Emacs General Public | |
12 ;; License for full details. | |
13 | |
14 ;; Everyone is granted permission to copy, modify and redistribute | |
15 ;; GNU Emacs, but only under the conditions described in the | |
16 ;; GNU Emacs General Public License. A copy of this license is | |
17 ;; supposed to have been given to you along with GNU Emacs so you | |
18 ;; can know your rights and responsibilities. It should be in a | |
19 ;; file named COPYING. Among other things, the copyright notice | |
20 ;; and this notice must be preserved on all copies. | |
21 | |
22 | |
23 | |
24 ;; This file is autoloaded from calc-ext.el. | |
25 (require 'calc-ext) | |
26 | |
27 (require 'calc-macs) | |
28 | |
29 (defun calc-Need-calc-math () nil) | |
30 | |
31 | |
32 (defun calc-sqrt (arg) | |
33 (interactive "P") | |
34 (calc-slow-wrapper | |
35 (if (calc-is-inverse) | |
36 (calc-unary-op "^2" 'calcFunc-sqr arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
37 (calc-unary-op "sqrt" 'calcFunc-sqrt arg)))) |
40785 | 38 |
39 (defun calc-isqrt (arg) | |
40 (interactive "P") | |
41 (calc-slow-wrapper | |
42 (if (calc-is-inverse) | |
43 (calc-unary-op "^2" 'calcFunc-sqr arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
44 (calc-unary-op "isqt" 'calcFunc-isqrt arg)))) |
40785 | 45 |
46 | |
47 (defun calc-hypot (arg) | |
48 (interactive "P") | |
49 (calc-slow-wrapper | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
50 (calc-binary-op "hypt" 'calcFunc-hypot arg))) |
40785 | 51 |
52 (defun calc-ln (arg) | |
53 (interactive "P") | |
54 (calc-invert-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
55 (calc-exp arg)) |
40785 | 56 |
57 (defun calc-log10 (arg) | |
58 (interactive "P") | |
59 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
60 (calc-ln arg)) |
40785 | 61 |
62 (defun calc-log (arg) | |
63 (interactive "P") | |
64 (calc-slow-wrapper | |
65 (if (calc-is-inverse) | |
66 (calc-binary-op "alog" 'calcFunc-alog arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
67 (calc-binary-op "log" 'calcFunc-log arg)))) |
40785 | 68 |
69 (defun calc-ilog (arg) | |
70 (interactive "P") | |
71 (calc-slow-wrapper | |
72 (if (calc-is-inverse) | |
73 (calc-binary-op "alog" 'calcFunc-alog arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
74 (calc-binary-op "ilog" 'calcFunc-ilog arg)))) |
40785 | 75 |
76 (defun calc-lnp1 (arg) | |
77 (interactive "P") | |
78 (calc-invert-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
79 (calc-expm1 arg)) |
40785 | 80 |
81 (defun calc-exp (arg) | |
82 (interactive "P") | |
83 (calc-slow-wrapper | |
84 (if (calc-is-hyperbolic) | |
85 (if (calc-is-inverse) | |
86 (calc-unary-op "lg10" 'calcFunc-log10 arg) | |
87 (calc-unary-op "10^" 'calcFunc-exp10 arg)) | |
88 (if (calc-is-inverse) | |
89 (calc-unary-op "ln" 'calcFunc-ln arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
90 (calc-unary-op "exp" 'calcFunc-exp arg))))) |
40785 | 91 |
92 (defun calc-expm1 (arg) | |
93 (interactive "P") | |
94 (calc-slow-wrapper | |
95 (if (calc-is-inverse) | |
96 (calc-unary-op "ln+1" 'calcFunc-lnp1 arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
97 (calc-unary-op "ex-1" 'calcFunc-expm1 arg)))) |
40785 | 98 |
99 (defun calc-pi () | |
100 (interactive) | |
101 (calc-slow-wrapper | |
102 (if (calc-is-inverse) | |
103 (if (calc-is-hyperbolic) | |
104 (if calc-symbolic-mode | |
105 (calc-pop-push-record 0 "phi" '(var phi var-phi)) | |
106 (calc-pop-push-record 0 "phi" (math-phi))) | |
107 (if calc-symbolic-mode | |
108 (calc-pop-push-record 0 "gmma" '(var gamma var-gamma)) | |
109 (calc-pop-push-record 0 "gmma" (math-gamma-const)))) | |
110 (if (calc-is-hyperbolic) | |
111 (if calc-symbolic-mode | |
112 (calc-pop-push-record 0 "e" '(var e var-e)) | |
113 (calc-pop-push-record 0 "e" (math-e))) | |
114 (if calc-symbolic-mode | |
115 (calc-pop-push-record 0 "pi" '(var pi var-pi)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
116 (calc-pop-push-record 0 "pi" (math-pi))))))) |
40785 | 117 |
118 (defun calc-sin (arg) | |
119 (interactive "P") | |
120 (calc-slow-wrapper | |
121 (if (calc-is-hyperbolic) | |
122 (if (calc-is-inverse) | |
123 (calc-unary-op "asnh" 'calcFunc-arcsinh arg) | |
124 (calc-unary-op "sinh" 'calcFunc-sinh arg)) | |
125 (if (calc-is-inverse) | |
126 (calc-unary-op "asin" 'calcFunc-arcsin arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
127 (calc-unary-op "sin" 'calcFunc-sin arg))))) |
40785 | 128 |
129 (defun calc-arcsin (arg) | |
130 (interactive "P") | |
131 (calc-invert-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
132 (calc-sin arg)) |
40785 | 133 |
134 (defun calc-sinh (arg) | |
135 (interactive "P") | |
136 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
137 (calc-sin arg)) |
40785 | 138 |
139 (defun calc-arcsinh (arg) | |
140 (interactive "P") | |
141 (calc-invert-func) | |
142 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
143 (calc-sin arg)) |
40785 | 144 |
145 (defun calc-cos (arg) | |
146 (interactive "P") | |
147 (calc-slow-wrapper | |
148 (if (calc-is-hyperbolic) | |
149 (if (calc-is-inverse) | |
150 (calc-unary-op "acsh" 'calcFunc-arccosh arg) | |
151 (calc-unary-op "cosh" 'calcFunc-cosh arg)) | |
152 (if (calc-is-inverse) | |
153 (calc-unary-op "acos" 'calcFunc-arccos arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
154 (calc-unary-op "cos" 'calcFunc-cos arg))))) |
40785 | 155 |
156 (defun calc-arccos (arg) | |
157 (interactive "P") | |
158 (calc-invert-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
159 (calc-cos arg)) |
40785 | 160 |
161 (defun calc-cosh (arg) | |
162 (interactive "P") | |
163 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
164 (calc-cos arg)) |
40785 | 165 |
166 (defun calc-arccosh (arg) | |
167 (interactive "P") | |
168 (calc-invert-func) | |
169 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
170 (calc-cos arg)) |
40785 | 171 |
172 (defun calc-sincos () | |
173 (interactive) | |
174 (calc-slow-wrapper | |
175 (if (calc-is-inverse) | |
176 (calc-enter-result 1 "asnc" (list 'calcFunc-arcsincos (calc-top-n 1))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
177 (calc-enter-result 1 "sncs" (list 'calcFunc-sincos (calc-top-n 1)))))) |
40785 | 178 |
179 (defun calc-tan (arg) | |
180 (interactive "P") | |
181 (calc-slow-wrapper | |
182 (if (calc-is-hyperbolic) | |
183 (if (calc-is-inverse) | |
184 (calc-unary-op "atnh" 'calcFunc-arctanh arg) | |
185 (calc-unary-op "tanh" 'calcFunc-tanh arg)) | |
186 (if (calc-is-inverse) | |
187 (calc-unary-op "atan" 'calcFunc-arctan arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
188 (calc-unary-op "tan" 'calcFunc-tan arg))))) |
40785 | 189 |
190 (defun calc-arctan (arg) | |
191 (interactive "P") | |
192 (calc-invert-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
193 (calc-tan arg)) |
40785 | 194 |
195 (defun calc-tanh (arg) | |
196 (interactive "P") | |
197 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
198 (calc-tan arg)) |
40785 | 199 |
200 (defun calc-arctanh (arg) | |
201 (interactive "P") | |
202 (calc-invert-func) | |
203 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
204 (calc-tan arg)) |
40785 | 205 |
206 (defun calc-arctan2 () | |
207 (interactive) | |
208 (calc-slow-wrapper | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
209 (calc-enter-result 2 "atn2" (cons 'calcFunc-arctan2 (calc-top-list-n 2))))) |
40785 | 210 |
211 (defun calc-conj (arg) | |
212 (interactive "P") | |
213 (calc-wrapper | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
214 (calc-unary-op "conj" 'calcFunc-conj arg))) |
40785 | 215 |
216 (defun calc-imaginary () | |
217 (interactive) | |
218 (calc-slow-wrapper | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
219 (calc-pop-push-record 1 "i*" (math-imaginary (calc-top-n 1))))) |
40785 | 220 |
221 | |
222 | |
223 (defun calc-to-degrees (arg) | |
224 (interactive "P") | |
225 (calc-wrapper | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
226 (calc-unary-op ">deg" 'calcFunc-deg arg))) |
40785 | 227 |
228 (defun calc-to-radians (arg) | |
229 (interactive "P") | |
230 (calc-wrapper | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
231 (calc-unary-op ">rad" 'calcFunc-rad arg))) |
40785 | 232 |
233 | |
234 (defun calc-degrees-mode (arg) | |
235 (interactive "p") | |
236 (cond ((= arg 1) | |
237 (calc-wrapper | |
238 (calc-change-mode 'calc-angle-mode 'deg) | |
239 (message "Angles measured in degrees."))) | |
240 ((= arg 2) (calc-radians-mode)) | |
241 ((= arg 3) (calc-hms-mode)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
242 (t (error "Prefix argument out of range")))) |
40785 | 243 |
244 (defun calc-radians-mode () | |
245 (interactive) | |
246 (calc-wrapper | |
247 (calc-change-mode 'calc-angle-mode 'rad) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
248 (message "Angles measured in radians."))) |
40785 | 249 |
250 | |
251 ;;; Compute the integer square-root floor(sqrt(A)). A > 0. [I I] [Public] | |
252 ;;; This method takes advantage of the fact that Newton's method starting | |
253 ;;; with an overestimate always works, even using truncating integer division! | |
254 (defun math-isqrt (a) | |
255 (cond ((Math-zerop a) a) | |
256 ((not (math-natnump a)) | |
257 (math-reject-arg a 'natnump)) | |
258 ((integerp a) | |
259 (math-isqrt-small a)) | |
260 (t | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
261 (math-normalize (cons 'bigpos (cdr (math-isqrt-bignum (cdr a)))))))) |
40785 | 262 |
263 (defun calcFunc-isqrt (a) | |
264 (if (math-realp a) | |
265 (math-isqrt (math-floor a)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
266 (math-floor (math-sqrt a)))) |
40785 | 267 |
268 | |
269 ;;; This returns (flag . result) where the flag is T if A is a perfect square. | |
270 (defun math-isqrt-bignum (a) ; [P.l L] | |
271 (let ((len (length a))) | |
272 (if (= (% len 2) 0) | |
273 (let* ((top (nthcdr (- len 2) a))) | |
274 (math-isqrt-bignum-iter | |
275 a | |
276 (math-scale-bignum-3 | |
277 (math-bignum-big | |
278 (1+ (math-isqrt-small | |
279 (+ (* (nth 1 top) 1000) (car top))))) | |
280 (1- (/ len 2))))) | |
281 (let* ((top (nth (1- len) a))) | |
282 (math-isqrt-bignum-iter | |
283 a | |
284 (math-scale-bignum-3 | |
285 (list (1+ (math-isqrt-small top))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
286 (/ len 2))))))) |
40785 | 287 |
288 (defun math-isqrt-bignum-iter (a guess) ; [l L l] | |
289 (math-working "isqrt" (cons 'bigpos guess)) | |
290 (let* ((q (math-div-bignum a guess)) | |
291 (s (math-add-bignum (car q) guess)) | |
292 (g2 (math-div2-bignum s)) | |
293 (comp (math-compare-bignum g2 guess))) | |
294 (if (< comp 0) | |
295 (math-isqrt-bignum-iter a g2) | |
296 (cons (and (= comp 0) | |
297 (math-zerop-bignum (cdr q)) | |
298 (= (% (car s) 2) 0)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
299 guess)))) |
40785 | 300 |
301 (defun math-zerop-bignum (a) | |
302 (and (eq (car a) 0) | |
303 (progn | |
304 (while (eq (car (setq a (cdr a))) 0)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
305 (null a)))) |
40785 | 306 |
307 (defun math-scale-bignum-3 (a n) ; [L L S] | |
308 (while (> n 0) | |
309 (setq a (cons 0 a) | |
310 n (1- n))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
311 a) |
40785 | 312 |
313 (defun math-isqrt-small (a) ; A > 0. [S S] | |
314 (let ((g (cond ((>= a 10000) 1000) | |
315 ((>= a 100) 100) | |
316 (t 10))) | |
317 g2) | |
318 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) | |
319 (setq g g2)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
320 g)) |
40785 | 321 |
322 | |
323 | |
324 | |
325 ;;; Compute the square root of a number. | |
326 ;;; [T N] if possible, else [F N] if possible, else [C N]. [Public] | |
327 (defun math-sqrt (a) | |
328 (or | |
329 (and (Math-zerop a) a) | |
330 (and (math-known-nonposp a) | |
331 (math-imaginary (math-sqrt (math-neg a)))) | |
332 (and (integerp a) | |
333 (let ((sqrt (math-isqrt-small a))) | |
334 (if (= (* sqrt sqrt) a) | |
335 sqrt | |
336 (if calc-symbolic-mode | |
337 (list 'calcFunc-sqrt a) | |
338 (math-sqrt-float (math-float a) (math-float sqrt)))))) | |
339 (and (eq (car-safe a) 'bigpos) | |
340 (let* ((res (math-isqrt-bignum (cdr a))) | |
341 (sqrt (math-normalize (cons 'bigpos (cdr res))))) | |
342 (if (car res) | |
343 sqrt | |
344 (if calc-symbolic-mode | |
345 (list 'calcFunc-sqrt a) | |
346 (math-sqrt-float (math-float a) (math-float sqrt)))))) | |
347 (and (eq (car-safe a) 'frac) | |
348 (let* ((num-res (math-isqrt-bignum (cdr (Math-bignum-test (nth 1 a))))) | |
349 (num-sqrt (math-normalize (cons 'bigpos (cdr num-res)))) | |
350 (den-res (math-isqrt-bignum (cdr (Math-bignum-test (nth 2 a))))) | |
351 (den-sqrt (math-normalize (cons 'bigpos (cdr den-res))))) | |
352 (if (and (car num-res) (car den-res)) | |
353 (list 'frac num-sqrt den-sqrt) | |
354 (if calc-symbolic-mode | |
355 (if (or (car num-res) (car den-res)) | |
356 (math-div (if (car num-res) | |
357 num-sqrt (list 'calcFunc-sqrt (nth 1 a))) | |
358 (if (car den-res) | |
359 den-sqrt (list 'calcFunc-sqrt (nth 2 a)))) | |
360 (list 'calcFunc-sqrt a)) | |
361 (math-sqrt-float (math-float a) | |
362 (math-div (math-float num-sqrt) den-sqrt)))))) | |
363 (and (eq (car-safe a) 'float) | |
364 (if calc-symbolic-mode | |
365 (if (= (% (nth 2 a) 2) 0) | |
366 (let ((res (math-isqrt-bignum | |
367 (cdr (Math-bignum-test (nth 1 a)))))) | |
368 (if (car res) | |
369 (math-make-float (math-normalize | |
370 (cons 'bigpos (cdr res))) | |
371 (/ (nth 2 a) 2)) | |
372 (signal 'inexact-result nil))) | |
373 (signal 'inexact-result nil)) | |
374 (math-sqrt-float a))) | |
375 (and (eq (car-safe a) 'cplx) | |
376 (math-with-extra-prec 2 | |
377 (let* ((d (math-abs a)) | |
378 (imag (math-sqrt (math-mul (math-sub d (nth 1 a)) | |
379 '(float 5 -1))))) | |
380 (list 'cplx | |
381 (math-sqrt (math-mul (math-add d (nth 1 a)) '(float 5 -1))) | |
382 (if (math-negp (nth 2 a)) (math-neg imag) imag))))) | |
383 (and (eq (car-safe a) 'polar) | |
384 (list 'polar | |
385 (math-sqrt (nth 1 a)) | |
386 (math-mul (nth 2 a) '(float 5 -1)))) | |
387 (and (eq (car-safe a) 'sdev) | |
388 (let ((sqrt (math-sqrt (nth 1 a)))) | |
389 (math-make-sdev sqrt | |
390 (math-div (nth 2 a) (math-mul sqrt 2))))) | |
391 (and (eq (car-safe a) 'intv) | |
392 (not (math-negp (nth 2 a))) | |
393 (math-make-intv (nth 1 a) (math-sqrt (nth 2 a)) (math-sqrt (nth 3 a)))) | |
394 (and (eq (car-safe a) '*) | |
395 (or (math-known-nonnegp (nth 1 a)) | |
396 (math-known-nonnegp (nth 2 a))) | |
397 (math-mul (math-sqrt (nth 1 a)) (math-sqrt (nth 2 a)))) | |
398 (and (eq (car-safe a) '/) | |
399 (or (and (math-known-nonnegp (nth 2 a)) | |
400 (math-div (math-sqrt (nth 1 a)) (math-sqrt (nth 2 a)))) | |
401 (and (math-known-nonnegp (nth 1 a)) | |
402 (not (math-equal-int (nth 1 a) 1)) | |
403 (math-mul (math-sqrt (nth 1 a)) | |
404 (math-sqrt (math-div 1 (nth 2 a))))))) | |
405 (and (eq (car-safe a) '^) | |
406 (math-known-evenp (nth 2 a)) | |
407 (math-known-realp (nth 1 a)) | |
408 (math-abs (math-pow (nth 1 a) (math-div (nth 2 a) 2)))) | |
409 (let ((inf (math-infinitep a))) | |
410 (and inf | |
411 (math-mul (math-sqrt (math-infinite-dir a inf)) inf))) | |
412 (progn | |
413 (calc-record-why 'numberp a) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
414 (list 'calcFunc-sqrt a)))) |
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
415 (defalias calcFunc-sqrt 'math-sqrt) |
40785 | 416 |
417 (defun math-infinite-dir (a &optional inf) | |
418 (or inf (setq inf (math-infinitep a))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
419 (math-normalize (math-expr-subst a inf 1))) |
40785 | 420 |
421 (defun math-sqrt-float (a &optional guess) ; [F F F] | |
422 (if calc-symbolic-mode | |
423 (signal 'inexact-result nil) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
424 (math-with-extra-prec 1 (math-sqrt-raw a guess)))) |
40785 | 425 |
426 (defun math-sqrt-raw (a &optional guess) ; [F F F] | |
427 (if (not (Math-posp a)) | |
428 (math-sqrt a) | |
429 (if (null guess) | |
430 (let ((ldiff (- (math-numdigs (nth 1 a)) 6))) | |
431 (or (= (% (+ (nth 2 a) ldiff) 2) 0) (setq ldiff (1+ ldiff))) | |
432 (setq guess (math-make-float (math-isqrt-small | |
433 (math-scale-int (nth 1 a) (- ldiff))) | |
434 (/ (+ (nth 2 a) ldiff) 2))))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
435 (math-sqrt-float-iter a guess))) |
40785 | 436 |
437 (defun math-sqrt-float-iter (a guess) ; [F F F] | |
438 (math-working "sqrt" guess) | |
439 (let ((g2 (math-mul-float (math-add-float guess (math-div-float a guess)) | |
440 '(float 5 -1)))) | |
441 (if (math-nearly-equal-float g2 guess) | |
442 g2 | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
443 (math-sqrt-float-iter a g2)))) |
40785 | 444 |
445 ;;; True if A and B differ only in the last digit of precision. [P F F] | |
446 (defun math-nearly-equal-float (a b) | |
447 (let ((ediff (- (nth 2 a) (nth 2 b)))) | |
448 (cond ((= ediff 0) ;; Expanded out for speed | |
449 (setq ediff (math-add (Math-integer-neg (nth 1 a)) (nth 1 b))) | |
450 (or (eq ediff 0) | |
451 (and (not (consp ediff)) | |
452 (< ediff 10) | |
453 (> ediff -10) | |
454 (= (math-numdigs (nth 1 a)) calc-internal-prec)))) | |
455 ((= ediff 1) | |
456 (setq ediff (math-add (Math-integer-neg (nth 1 b)) | |
457 (math-scale-int (nth 1 a) 1))) | |
458 (and (not (consp ediff)) | |
459 (< ediff 10) | |
460 (> ediff -10) | |
461 (= (math-numdigs (nth 1 b)) calc-internal-prec))) | |
462 ((= ediff -1) | |
463 (setq ediff (math-add (Math-integer-neg (nth 1 a)) | |
464 (math-scale-int (nth 1 b) 1))) | |
465 (and (not (consp ediff)) | |
466 (< ediff 10) | |
467 (> ediff -10) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
468 (= (math-numdigs (nth 1 a)) calc-internal-prec)))))) |
40785 | 469 |
470 (defun math-nearly-equal (a b) ; [P N N] [Public] | |
471 (setq a (math-float a)) | |
472 (setq b (math-float b)) | |
473 (if (eq (car a) 'polar) (setq a (math-complex a))) | |
474 (if (eq (car b) 'polar) (setq b (math-complex b))) | |
475 (if (eq (car a) 'cplx) | |
476 (if (eq (car b) 'cplx) | |
477 (and (or (math-nearly-equal-float (nth 1 a) (nth 1 b)) | |
478 (and (math-nearly-zerop-float (nth 1 a) (nth 2 a)) | |
479 (math-nearly-zerop-float (nth 1 b) (nth 2 b)))) | |
480 (or (math-nearly-equal-float (nth 2 a) (nth 2 b)) | |
481 (and (math-nearly-zerop-float (nth 2 a) (nth 1 a)) | |
482 (math-nearly-zerop-float (nth 2 b) (nth 1 b))))) | |
483 (and (math-nearly-equal-float (nth 1 a) b) | |
484 (math-nearly-zerop-float (nth 2 a) b))) | |
485 (if (eq (car b) 'cplx) | |
486 (and (math-nearly-equal-float a (nth 1 b)) | |
487 (math-nearly-zerop-float a (nth 2 b))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
488 (math-nearly-equal-float a b)))) |
40785 | 489 |
490 ;;; True if A is nearly zero compared to B. [P F F] | |
491 (defun math-nearly-zerop-float (a b) | |
492 (or (eq (nth 1 a) 0) | |
493 (<= (+ (math-numdigs (nth 1 a)) (nth 2 a)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
494 (1+ (- (+ (math-numdigs (nth 1 b)) (nth 2 b)) calc-internal-prec))))) |
40785 | 495 |
496 (defun math-nearly-zerop (a b) ; [P N R] [Public] | |
497 (setq a (math-float a)) | |
498 (setq b (math-float b)) | |
499 (if (eq (car a) 'cplx) | |
500 (and (math-nearly-zerop-float (nth 1 a) b) | |
501 (math-nearly-zerop-float (nth 2 a) b)) | |
502 (if (eq (car a) 'polar) | |
503 (math-nearly-zerop-float (nth 1 a) b) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
504 (math-nearly-zerop-float a b)))) |
40785 | 505 |
506 ;;; This implementation could be improved, accuracy-wise. | |
507 (defun math-hypot (a b) | |
508 (cond ((Math-zerop a) (math-abs b)) | |
509 ((Math-zerop b) (math-abs a)) | |
510 ((not (Math-scalarp a)) | |
511 (if (math-infinitep a) | |
512 (if (math-infinitep b) | |
513 (if (equal a b) | |
514 a | |
515 '(var nan var-nan)) | |
516 a) | |
517 (calc-record-why 'scalarp a) | |
518 (list 'calcFunc-hypot a b))) | |
519 ((not (Math-scalarp b)) | |
520 (if (math-infinitep b) | |
521 b | |
522 (calc-record-why 'scalarp b) | |
523 (list 'calcFunc-hypot a b))) | |
524 ((and (Math-numberp a) (Math-numberp b)) | |
525 (math-with-extra-prec 1 | |
526 (math-sqrt (math-add (calcFunc-abssqr a) (calcFunc-abssqr b))))) | |
527 ((eq (car-safe a) 'hms) | |
528 (if (eq (car-safe b) 'hms) ; this helps sdev's of hms forms | |
529 (math-to-hms (math-hypot (math-from-hms a 'deg) | |
530 (math-from-hms b 'deg))) | |
531 (math-to-hms (math-hypot (math-from-hms a 'deg) b)))) | |
532 ((eq (car-safe b) 'hms) | |
533 (math-to-hms (math-hypot a (math-from-hms b 'deg)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
534 (t nil))) |
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
535 (defalias calcFunc-hypot 'math-hypot) |
40785 | 536 |
537 (defun calcFunc-sqr (x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
538 (math-pow x 2)) |
40785 | 539 |
540 | |
541 | |
542 (defun math-nth-root (a n) | |
543 (cond ((= n 2) (math-sqrt a)) | |
544 ((Math-zerop a) a) | |
545 ((Math-negp a) nil) | |
546 ((Math-integerp a) | |
547 (let ((root (math-nth-root-integer a n))) | |
548 (if (car root) | |
549 (cdr root) | |
550 (and (not calc-symbolic-mode) | |
551 (math-nth-root-float (math-float a) n | |
552 (math-float (cdr root))))))) | |
553 ((eq (car-safe a) 'frac) | |
554 (let* ((num-root (math-nth-root-integer (nth 1 a) n)) | |
555 (den-root (math-nth-root-integer (nth 2 a) n))) | |
556 (if (and (car num-root) (car den-root)) | |
557 (list 'frac (cdr num-root) (cdr den-root)) | |
558 (and (not calc-symbolic-mode) | |
559 (math-nth-root-float | |
560 (math-float a) n | |
561 (math-div-float (math-float (cdr num-root)) | |
562 (math-float (cdr den-root)))))))) | |
563 ((eq (car-safe a) 'float) | |
564 (and (not calc-symbolic-mode) | |
565 (math-nth-root-float a n))) | |
566 ((eq (car-safe a) 'polar) | |
567 (let ((root (math-nth-root (nth 1 a) n))) | |
568 (and root (list 'polar root (math-div (nth 2 a) n))))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
569 (t nil))) |
40785 | 570 |
571 (defun math-nth-root-float (a n &optional guess) | |
572 (math-inexact-result) | |
573 (math-with-extra-prec 1 | |
574 (let ((nf (math-float n)) | |
575 (nfm1 (math-float (1- n)))) | |
576 (math-nth-root-float-iter a (or guess | |
577 (math-make-float | |
578 1 (/ (+ (math-numdigs (nth 1 a)) | |
579 (nth 2 a) | |
580 (/ n 2)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
581 n))))))) |
40785 | 582 |
583 (defun math-nth-root-float-iter (a guess) ; uses "n", "nf", "nfm1" | |
584 (math-working "root" guess) | |
585 (let ((g2 (math-div-float (math-add-float (math-mul nfm1 guess) | |
586 (math-div-float | |
587 a (math-ipow guess (1- n)))) | |
588 nf))) | |
589 (if (math-nearly-equal-float g2 guess) | |
590 g2 | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
591 (math-nth-root-float-iter a g2)))) |
40785 | 592 |
593 (defun math-nth-root-integer (a n &optional guess) ; [I I S] | |
594 (math-nth-root-int-iter a (or guess | |
595 (math-scale-int 1 (/ (+ (math-numdigs a) | |
596 (1- n)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
597 n))))) |
40785 | 598 |
599 (defun math-nth-root-int-iter (a guess) ; uses "n" | |
600 (math-working "root" guess) | |
601 (let* ((q (math-idivmod a (math-ipow guess (1- n)))) | |
602 (s (math-add (car q) (math-mul (1- n) guess))) | |
603 (g2 (math-idivmod s n))) | |
604 (if (Math-natnum-lessp (car g2) guess) | |
605 (math-nth-root-int-iter a (car g2)) | |
606 (cons (and (equal (car g2) guess) | |
607 (eq (cdr q) 0) | |
608 (eq (cdr g2) 0)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
609 guess)))) |
40785 | 610 |
611 (defun calcFunc-nroot (x n) | |
612 (calcFunc-pow x (if (integerp n) | |
613 (math-make-frac 1 n) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
614 (math-div 1 n)))) |
40785 | 615 |
616 | |
617 | |
618 | |
619 ;;;; Transcendental functions. | |
620 | |
621 ;;; All of these functions are defined on the complex plane. | |
622 ;;; (Branch cuts, etc. follow Steele's Common Lisp book.) | |
623 | |
624 ;;; Most functions increase calc-internal-prec by 2 digits, then round | |
625 ;;; down afterward. "-raw" functions use the current precision, require | |
626 ;;; their arguments to be in float (or complex float) format, and always | |
627 ;;; work in radians (where applicable). | |
628 | |
629 (defun math-to-radians (a) ; [N N] | |
630 (cond ((eq (car-safe a) 'hms) | |
631 (math-from-hms a 'rad)) | |
632 ((memq calc-angle-mode '(deg hms)) | |
633 (math-mul a (math-pi-over-180))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
634 (t a))) |
40785 | 635 |
636 (defun math-from-radians (a) ; [N N] | |
637 (cond ((eq calc-angle-mode 'deg) | |
638 (if (math-constp a) | |
639 (math-div a (math-pi-over-180)) | |
640 (list 'calcFunc-deg a))) | |
641 ((eq calc-angle-mode 'hms) | |
642 (math-to-hms a 'rad)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
643 (t a))) |
40785 | 644 |
645 (defun math-to-radians-2 (a) ; [N N] | |
646 (cond ((eq (car-safe a) 'hms) | |
647 (math-from-hms a 'rad)) | |
648 ((memq calc-angle-mode '(deg hms)) | |
649 (if calc-symbolic-mode | |
650 (math-div (math-mul a '(var pi var-pi)) 180) | |
651 (math-mul a (math-pi-over-180)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
652 (t a))) |
40785 | 653 |
654 (defun math-from-radians-2 (a) ; [N N] | |
655 (cond ((memq calc-angle-mode '(deg hms)) | |
656 (if calc-symbolic-mode | |
657 (math-div (math-mul 180 a) '(var pi var-pi)) | |
658 (math-div a (math-pi-over-180)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
659 (t a))) |
40785 | 660 |
661 | |
662 | |
663 ;;; Sine, cosine, and tangent. | |
664 | |
665 (defun calcFunc-sin (x) ; [N N] [Public] | |
666 (cond ((and (integerp x) | |
667 (if (eq calc-angle-mode 'deg) | |
668 (= (% x 90) 0) | |
669 (= x 0))) | |
670 (aref [0 1 0 -1] (math-mod (/ x 90) 4))) | |
671 ((Math-scalarp x) | |
672 (math-with-extra-prec 2 | |
673 (math-sin-raw (math-to-radians (math-float x))))) | |
674 ((eq (car x) 'sdev) | |
675 (if (math-constp x) | |
676 (math-with-extra-prec 2 | |
677 (let* ((xx (math-to-radians (math-float (nth 1 x)))) | |
678 (xs (math-to-radians (math-float (nth 2 x)))) | |
679 (sc (math-sin-cos-raw xx))) | |
680 (math-make-sdev (car sc) (math-mul xs (cdr sc))))) | |
681 (math-make-sdev (calcFunc-sin (nth 1 x)) | |
682 (math-mul (nth 2 x) (calcFunc-cos (nth 1 x)))))) | |
683 ((and (eq (car x) 'intv) (math-intv-constp x)) | |
684 (calcFunc-cos (math-sub x (math-quarter-circle nil)))) | |
685 ((equal x '(var nan var-nan)) | |
686 x) | |
687 (t (calc-record-why 'scalarp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
688 (list 'calcFunc-sin x)))) |
40785 | 689 |
690 (defun calcFunc-cos (x) ; [N N] [Public] | |
691 (cond ((and (integerp x) | |
692 (if (eq calc-angle-mode 'deg) | |
693 (= (% x 90) 0) | |
694 (= x 0))) | |
695 (aref [1 0 -1 0] (math-mod (/ x 90) 4))) | |
696 ((Math-scalarp x) | |
697 (math-with-extra-prec 2 | |
698 (math-cos-raw (math-to-radians (math-float x))))) | |
699 ((eq (car x) 'sdev) | |
700 (if (math-constp x) | |
701 (math-with-extra-prec 2 | |
702 (let* ((xx (math-to-radians (math-float (nth 1 x)))) | |
703 (xs (math-to-radians (math-float (nth 2 x)))) | |
704 (sc (math-sin-cos-raw xx))) | |
705 (math-make-sdev (cdr sc) (math-mul xs (car sc))))) | |
706 (math-make-sdev (calcFunc-cos (nth 1 x)) | |
707 (math-mul (nth 2 x) (calcFunc-sin (nth 1 x)))))) | |
708 ((and (eq (car x) 'intv) (math-intv-constp x)) | |
709 (math-with-extra-prec 2 | |
710 (let* ((xx (math-to-radians (math-float x))) | |
711 (na (math-floor (math-div (nth 2 xx) (math-pi)))) | |
712 (nb (math-floor (math-div (nth 3 xx) (math-pi)))) | |
713 (span (math-sub nb na))) | |
714 (if (memq span '(0 1)) | |
715 (let ((int (math-sort-intv (nth 1 x) | |
716 (math-cos-raw (nth 2 xx)) | |
717 (math-cos-raw (nth 3 xx))))) | |
718 (if (eq span 1) | |
719 (if (math-evenp na) | |
720 (math-make-intv (logior (nth 1 x) 2) | |
721 -1 | |
722 (nth 3 int)) | |
723 (math-make-intv (logior (nth 1 x) 1) | |
724 (nth 2 int) | |
725 1)) | |
726 int)) | |
727 (list 'intv 3 -1 1))))) | |
728 ((equal x '(var nan var-nan)) | |
729 x) | |
730 (t (calc-record-why 'scalarp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
731 (list 'calcFunc-cos x)))) |
40785 | 732 |
733 (defun calcFunc-sincos (x) ; [V N] [Public] | |
734 (if (Math-scalarp x) | |
735 (math-with-extra-prec 2 | |
736 (let ((sc (math-sin-cos-raw (math-to-radians (math-float x))))) | |
737 (list 'vec (cdr sc) (car sc)))) ; the vector [cos, sin] | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
738 (list 'vec (calcFunc-sin x) (calcFunc-cos x)))) |
40785 | 739 |
740 (defun calcFunc-tan (x) ; [N N] [Public] | |
741 (cond ((and (integerp x) | |
742 (if (eq calc-angle-mode 'deg) | |
743 (= (% x 180) 0) | |
744 (= x 0))) | |
745 0) | |
746 ((Math-scalarp x) | |
747 (math-with-extra-prec 2 | |
748 (math-tan-raw (math-to-radians (math-float x))))) | |
749 ((eq (car x) 'sdev) | |
750 (if (math-constp x) | |
751 (math-with-extra-prec 2 | |
752 (let* ((xx (math-to-radians (math-float (nth 1 x)))) | |
753 (xs (math-to-radians (math-float (nth 2 x)))) | |
754 (sc (math-sin-cos-raw xx))) | |
755 (if (and (math-zerop (cdr sc)) (not calc-infinite-mode)) | |
756 (progn | |
757 (calc-record-why "*Division by zero") | |
758 (list 'calcFunc-tan x)) | |
759 (math-make-sdev (math-div-float (car sc) (cdr sc)) | |
760 (math-div-float xs (math-sqr (cdr sc))))))) | |
761 (math-make-sdev (calcFunc-tan (nth 1 x)) | |
762 (math-div (nth 2 x) | |
763 (math-sqr (calcFunc-cos (nth 1 x))))))) | |
764 ((and (eq (car x) 'intv) (math-intv-constp x)) | |
765 (or (math-with-extra-prec 2 | |
766 (let* ((xx (math-to-radians (math-float x))) | |
767 (na (math-floor (math-div (math-sub (nth 2 xx) | |
768 (math-pi-over-2)) | |
769 (math-pi)))) | |
770 (nb (math-floor (math-div (math-sub (nth 3 xx) | |
771 (math-pi-over-2)) | |
772 (math-pi))))) | |
773 (and (equal na nb) | |
774 (math-sort-intv (nth 1 x) | |
775 (math-tan-raw (nth 2 xx)) | |
776 (math-tan-raw (nth 3 xx)))))) | |
777 '(intv 3 (neg (var inf var-inf)) (var inf var-inf)))) | |
778 ((equal x '(var nan var-nan)) | |
779 x) | |
780 (t (calc-record-why 'scalarp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
781 (list 'calcFunc-tan x)))) |
40785 | 782 |
783 (defun math-sin-raw (x) ; [N N] | |
784 (cond ((eq (car x) 'cplx) | |
785 (let* ((expx (math-exp-raw (nth 2 x))) | |
786 (expmx (math-div-float '(float 1 0) expx)) | |
787 (sc (math-sin-cos-raw (nth 1 x)))) | |
788 (list 'cplx | |
789 (math-mul-float (car sc) | |
790 (math-mul-float (math-add-float expx expmx) | |
791 '(float 5 -1))) | |
792 (math-mul-float (cdr sc) | |
793 (math-mul-float (math-sub-float expx expmx) | |
794 '(float 5 -1)))))) | |
795 ((eq (car x) 'polar) | |
796 (math-polar (math-sin-raw (math-complex x)))) | |
797 ((Math-integer-negp (nth 1 x)) | |
798 (math-neg-float (math-sin-raw (math-neg-float x)))) | |
799 ((math-lessp-float '(float 7 0) x) ; avoid inf loops due to roundoff | |
800 (math-sin-raw (math-mod x (math-two-pi)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
801 (t (math-sin-raw-2 x x)))) |
40785 | 802 |
803 (defun math-cos-raw (x) ; [N N] | |
804 (if (eq (car-safe x) 'polar) | |
805 (math-polar (math-cos-raw (math-complex x))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
806 (math-sin-raw (math-sub (math-pi-over-2) x)))) |
40785 | 807 |
808 ;;; This could use a smarter method: Reduce x as in math-sin-raw, then | |
809 ;;; compute either sin(x) or cos(x), whichever is smaller, and compute | |
810 ;;; the other using the identity sin(x)^2 + cos(x)^2 = 1. | |
811 (defun math-sin-cos-raw (x) ; [F.F F] (result is (sin x . cos x)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
812 (cons (math-sin-raw x) (math-cos-raw x))) |
40785 | 813 |
814 (defun math-tan-raw (x) ; [N N] | |
815 (cond ((eq (car x) 'cplx) | |
816 (let* ((x (math-mul x '(float 2 0))) | |
817 (expx (math-exp-raw (nth 2 x))) | |
818 (expmx (math-div-float '(float 1 0) expx)) | |
819 (sc (math-sin-cos-raw (nth 1 x))) | |
820 (d (math-add-float (cdr sc) | |
821 (math-mul-float (math-add-float expx expmx) | |
822 '(float 5 -1))))) | |
823 (and (not (eq (nth 1 d) 0)) | |
824 (list 'cplx | |
825 (math-div-float (car sc) d) | |
826 (math-div-float (math-mul-float (math-sub-float expx | |
827 expmx) | |
828 '(float 5 -1)) d))))) | |
829 ((eq (car x) 'polar) | |
830 (math-polar (math-tan-raw (math-complex x)))) | |
831 (t | |
832 (let ((sc (math-sin-cos-raw x))) | |
833 (if (eq (nth 1 (cdr sc)) 0) | |
834 (math-div (car sc) 0) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
835 (math-div-float (car sc) (cdr sc))))))) |
40785 | 836 |
837 (defun math-sin-raw-2 (x orgx) ; This avoids poss of inf recursion. [F F] | |
838 (let ((xmpo2 (math-sub-float (math-pi-over-2) x))) | |
839 (cond ((Math-integer-negp (nth 1 xmpo2)) | |
840 (math-neg-float (math-sin-raw-2 (math-sub-float x (math-pi)) | |
841 orgx))) | |
842 ((math-lessp-float (math-pi-over-4) x) | |
843 (math-cos-raw-2 xmpo2 orgx)) | |
844 ((math-lessp-float x (math-neg (math-pi-over-4))) | |
845 (math-neg (math-cos-raw-2 (math-add (math-pi-over-2) x) orgx))) | |
846 ((math-nearly-zerop-float x orgx) '(float 0 0)) | |
847 (calc-symbolic-mode (signal 'inexact-result nil)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
848 (t (math-sin-series x 6 4 x (math-neg-float (math-sqr-float x))))))) |
40785 | 849 |
850 (defun math-cos-raw-2 (x orgx) ; [F F] | |
851 (cond ((math-nearly-zerop-float x orgx) '(float 1 0)) | |
852 (calc-symbolic-mode (signal 'inexact-result nil)) | |
853 (t (let ((xnegsqr (math-neg-float (math-sqr-float x)))) | |
854 (math-sin-series | |
855 (math-add-float '(float 1 0) | |
856 (math-mul-float xnegsqr '(float 5 -1))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
857 24 5 xnegsqr xnegsqr))))) |
40785 | 858 |
859 (defun math-sin-series (sum nfac n x xnegsqr) | |
860 (math-working "sin" sum) | |
861 (let* ((nextx (math-mul-float x xnegsqr)) | |
862 (nextsum (math-add-float sum (math-div-float nextx | |
863 (math-float nfac))))) | |
864 (if (math-nearly-equal-float sum nextsum) | |
865 sum | |
866 (math-sin-series nextsum (math-mul nfac (* n (1+ n))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
867 (+ n 2) nextx xnegsqr)))) |
40785 | 868 |
869 | |
870 ;;; Inverse sine, cosine, tangent. | |
871 | |
872 (defun calcFunc-arcsin (x) ; [N N] [Public] | |
873 (cond ((eq x 0) 0) | |
874 ((and (eq x 1) (eq calc-angle-mode 'deg)) 90) | |
875 ((and (eq x -1) (eq calc-angle-mode 'deg)) -90) | |
876 (calc-symbolic-mode (signal 'inexact-result nil)) | |
877 ((Math-numberp x) | |
878 (math-with-extra-prec 2 | |
879 (math-from-radians (math-arcsin-raw (math-float x))))) | |
880 ((eq (car x) 'sdev) | |
881 (math-make-sdev (calcFunc-arcsin (nth 1 x)) | |
882 (math-from-radians | |
883 (math-div (nth 2 x) | |
884 (math-sqrt | |
885 (math-sub 1 (math-sqr (nth 1 x)))))))) | |
886 ((eq (car x) 'intv) | |
887 (math-sort-intv (nth 1 x) | |
888 (calcFunc-arcsin (nth 2 x)) | |
889 (calcFunc-arcsin (nth 3 x)))) | |
890 ((equal x '(var nan var-nan)) | |
891 x) | |
892 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
893 (list 'calcFunc-arcsin x)))) |
40785 | 894 |
895 (defun calcFunc-arccos (x) ; [N N] [Public] | |
896 (cond ((eq x 1) 0) | |
897 ((and (eq x 0) (eq calc-angle-mode 'deg)) 90) | |
898 ((and (eq x -1) (eq calc-angle-mode 'deg)) 180) | |
899 (calc-symbolic-mode (signal 'inexact-result nil)) | |
900 ((Math-numberp x) | |
901 (math-with-extra-prec 2 | |
902 (math-from-radians (math-arccos-raw (math-float x))))) | |
903 ((eq (car x) 'sdev) | |
904 (math-make-sdev (calcFunc-arccos (nth 1 x)) | |
905 (math-from-radians | |
906 (math-div (nth 2 x) | |
907 (math-sqrt | |
908 (math-sub 1 (math-sqr (nth 1 x)))))))) | |
909 ((eq (car x) 'intv) | |
910 (math-sort-intv (nth 1 x) | |
911 (calcFunc-arccos (nth 2 x)) | |
912 (calcFunc-arccos (nth 3 x)))) | |
913 ((equal x '(var nan var-nan)) | |
914 x) | |
915 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
916 (list 'calcFunc-arccos x)))) |
40785 | 917 |
918 (defun calcFunc-arctan (x) ; [N N] [Public] | |
919 (cond ((eq x 0) 0) | |
920 ((and (eq x 1) (eq calc-angle-mode 'deg)) 45) | |
921 ((and (eq x -1) (eq calc-angle-mode 'deg)) -45) | |
922 ((Math-numberp x) | |
923 (math-with-extra-prec 2 | |
924 (math-from-radians (math-arctan-raw (math-float x))))) | |
925 ((eq (car x) 'sdev) | |
926 (math-make-sdev (calcFunc-arctan (nth 1 x)) | |
927 (math-from-radians | |
928 (math-div (nth 2 x) | |
929 (math-add 1 (math-sqr (nth 1 x))))))) | |
930 ((eq (car x) 'intv) | |
931 (math-sort-intv (nth 1 x) | |
932 (calcFunc-arctan (nth 2 x)) | |
933 (calcFunc-arctan (nth 3 x)))) | |
934 ((equal x '(var inf var-inf)) | |
935 (math-quarter-circle t)) | |
936 ((equal x '(neg (var inf var-inf))) | |
937 (math-neg (math-quarter-circle t))) | |
938 ((equal x '(var nan var-nan)) | |
939 x) | |
940 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
941 (list 'calcFunc-arctan x)))) |
40785 | 942 |
943 (defun math-arcsin-raw (x) ; [N N] | |
944 (let ((a (math-sqrt-raw (math-sub '(float 1 0) (math-sqr x))))) | |
945 (if (or (memq (car x) '(cplx polar)) | |
946 (memq (car a) '(cplx polar))) | |
947 (math-with-extra-prec 2 ; use extra precision for difficult case | |
948 (math-mul '(cplx 0 -1) | |
949 (math-ln-raw (math-add (math-mul '(cplx 0 1) x) a)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
950 (math-arctan2-raw x a)))) |
40785 | 951 |
952 (defun math-arccos-raw (x) ; [N N] | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
953 (math-sub (math-pi-over-2) (math-arcsin-raw x))) |
40785 | 954 |
955 (defun math-arctan-raw (x) ; [N N] | |
956 (cond ((memq (car x) '(cplx polar)) | |
957 (math-with-extra-prec 2 ; extra-extra | |
958 (math-div (math-sub | |
959 (math-ln-raw (math-add 1 (math-mul '(cplx 0 1) x))) | |
960 (math-ln-raw (math-add 1 (math-mul '(cplx 0 -1) x)))) | |
961 '(cplx 0 2)))) | |
962 ((Math-integer-negp (nth 1 x)) | |
963 (math-neg-float (math-arctan-raw (math-neg-float x)))) | |
964 ((math-zerop x) x) | |
965 (calc-symbolic-mode (signal 'inexact-result nil)) | |
966 ((math-equal-int x 1) (math-pi-over-4)) | |
967 ((math-equal-int x -1) (math-neg (math-pi-over-4))) | |
968 ((math-lessp-float '(float 414214 -6) x) ; if x > sqrt(2) - 1, reduce | |
969 (if (math-lessp-float '(float 1 0) x) | |
970 (math-sub-float (math-mul-float (math-pi) '(float 5 -1)) | |
971 (math-arctan-raw (math-div-float '(float 1 0) x))) | |
972 (math-sub-float (math-mul-float (math-pi) '(float 25 -2)) | |
973 (math-arctan-raw (math-div-float | |
974 (math-sub-float '(float 1 0) x) | |
975 (math-add-float '(float 1 0) | |
976 x)))))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
977 (t (math-arctan-series x 3 x (math-neg-float (math-sqr-float x)))))) |
40785 | 978 |
979 (defun math-arctan-series (sum n x xnegsqr) | |
980 (math-working "arctan" sum) | |
981 (let* ((nextx (math-mul-float x xnegsqr)) | |
982 (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) | |
983 (if (math-nearly-equal-float sum nextsum) | |
984 sum | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
985 (math-arctan-series nextsum (+ n 2) nextx xnegsqr)))) |
40785 | 986 |
987 (defun calcFunc-arctan2 (y x) ; [F R R] [Public] | |
988 (if (Math-anglep y) | |
989 (if (Math-anglep x) | |
990 (math-with-extra-prec 2 | |
991 (math-from-radians (math-arctan2-raw (math-float y) | |
992 (math-float x)))) | |
993 (calc-record-why 'anglep x) | |
994 (list 'calcFunc-arctan2 y x)) | |
995 (if (and (or (math-infinitep x) (math-anglep x)) | |
996 (or (math-infinitep y) (math-anglep y))) | |
997 (progn | |
998 (if (math-posp x) | |
999 (setq x 1) | |
1000 (if (math-negp x) | |
1001 (setq x -1) | |
1002 (or (math-zerop x) | |
1003 (setq x nil)))) | |
1004 (if (math-posp y) | |
1005 (setq y 1) | |
1006 (if (math-negp y) | |
1007 (setq y -1) | |
1008 (or (math-zerop y) | |
1009 (setq y nil)))) | |
1010 (if (and y x) | |
1011 (calcFunc-arctan2 y x) | |
1012 '(var nan var-nan))) | |
1013 (calc-record-why 'anglep y) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1014 (list 'calcFunc-arctan2 y x)))) |
40785 | 1015 |
1016 (defun math-arctan2-raw (y x) ; [F R R] | |
1017 (cond ((math-zerop y) | |
1018 (if (math-negp x) (math-pi) | |
1019 (if (or (math-floatp x) (math-floatp y)) '(float 0 0) 0))) | |
1020 ((math-zerop x) | |
1021 (if (math-posp y) | |
1022 (math-pi-over-2) | |
1023 (math-neg (math-pi-over-2)))) | |
1024 ((math-posp x) | |
1025 (math-arctan-raw (math-div-float y x))) | |
1026 ((math-posp y) | |
1027 (math-add-float (math-arctan-raw (math-div-float y x)) | |
1028 (math-pi))) | |
1029 (t | |
1030 (math-sub-float (math-arctan-raw (math-div-float y x)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1031 (math-pi))))) |
40785 | 1032 |
1033 (defun calcFunc-arcsincos (x) ; [V N] [Public] | |
1034 (if (and (Math-vectorp x) | |
1035 (= (length x) 3)) | |
1036 (calcFunc-arctan2 (nth 2 x) (nth 1 x)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1037 (math-reject-arg x "*Two-element vector expected"))) |
40785 | 1038 |
1039 | |
1040 | |
1041 ;;; Exponential function. | |
1042 | |
1043 (defun calcFunc-exp (x) ; [N N] [Public] | |
1044 (cond ((eq x 0) 1) | |
1045 ((and (memq x '(1 -1)) calc-symbolic-mode) | |
1046 (if (eq x 1) '(var e var-e) (math-div 1 '(var e var-e)))) | |
1047 ((Math-numberp x) | |
1048 (math-with-extra-prec 2 (math-exp-raw (math-float x)))) | |
1049 ((eq (car-safe x) 'sdev) | |
1050 (let ((ex (calcFunc-exp (nth 1 x)))) | |
1051 (math-make-sdev ex (math-mul (nth 2 x) ex)))) | |
1052 ((eq (car-safe x) 'intv) | |
1053 (math-make-intv (nth 1 x) (calcFunc-exp (nth 2 x)) | |
1054 (calcFunc-exp (nth 3 x)))) | |
1055 ((equal x '(var inf var-inf)) | |
1056 x) | |
1057 ((equal x '(neg (var inf var-inf))) | |
1058 0) | |
1059 ((equal x '(var nan var-nan)) | |
1060 x) | |
1061 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1062 (list 'calcFunc-exp x)))) |
40785 | 1063 |
1064 (defun calcFunc-expm1 (x) ; [N N] [Public] | |
1065 (cond ((eq x 0) 0) | |
1066 ((math-zerop x) '(float 0 0)) | |
1067 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1068 ((Math-numberp x) | |
1069 (math-with-extra-prec 2 | |
1070 (let ((x (math-float x))) | |
1071 (if (and (eq (car x) 'float) | |
1072 (math-lessp-float x '(float 1 0)) | |
1073 (math-lessp-float '(float -1 0) x)) | |
1074 (math-exp-minus-1-raw x) | |
1075 (math-add (math-exp-raw x) -1))))) | |
1076 ((eq (car-safe x) 'sdev) | |
1077 (if (math-constp x) | |
1078 (let ((ex (calcFunc-expm1 (nth 1 x)))) | |
1079 (math-make-sdev ex (math-mul (nth 2 x) (math-add ex 1)))) | |
1080 (math-make-sdev (calcFunc-expm1 (nth 1 x)) | |
1081 (math-mul (nth 2 x) (calcFunc-exp (nth 1 x)))))) | |
1082 ((eq (car-safe x) 'intv) | |
1083 (math-make-intv (nth 1 x) | |
1084 (calcFunc-expm1 (nth 2 x)) | |
1085 (calcFunc-expm1 (nth 3 x)))) | |
1086 ((equal x '(var inf var-inf)) | |
1087 x) | |
1088 ((equal x '(neg (var inf var-inf))) | |
1089 -1) | |
1090 ((equal x '(var nan var-nan)) | |
1091 x) | |
1092 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1093 (list 'calcFunc-expm1 x)))) |
40785 | 1094 |
1095 (defun calcFunc-exp10 (x) ; [N N] [Public] | |
1096 (if (eq x 0) | |
1097 1 | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1098 (math-pow '(float 1 1) x))) |
40785 | 1099 |
1100 (defun math-exp-raw (x) ; [N N] | |
1101 (cond ((math-zerop x) '(float 1 0)) | |
1102 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1103 ((eq (car x) 'cplx) | |
1104 (let ((expx (math-exp-raw (nth 1 x))) | |
1105 (sc (math-sin-cos-raw (nth 2 x)))) | |
1106 (list 'cplx | |
1107 (math-mul-float expx (cdr sc)) | |
1108 (math-mul-float expx (car sc))))) | |
1109 ((eq (car x) 'polar) | |
1110 (let ((xc (math-complex x))) | |
1111 (list 'polar | |
1112 (math-exp-raw (nth 1 xc)) | |
1113 (math-from-radians (nth 2 xc))))) | |
1114 ((or (math-lessp-float '(float 5 -1) x) | |
1115 (math-lessp-float x '(float -5 -1))) | |
1116 (if (math-lessp-float '(float 921035 1) x) | |
1117 (math-overflow) | |
1118 (if (math-lessp-float x '(float -921035 1)) | |
1119 (math-underflow))) | |
1120 (let* ((two-x (math-mul-float x '(float 2 0))) | |
1121 (hint (math-scale-int (nth 1 two-x) (nth 2 two-x))) | |
1122 (hfrac (math-sub-float x (math-mul-float (math-float hint) | |
1123 '(float 5 -1))))) | |
1124 (math-mul-float (math-ipow (math-sqrt-e) hint) | |
1125 (math-add-float '(float 1 0) | |
1126 (math-exp-minus-1-raw hfrac))))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1127 (t (math-add-float '(float 1 0) (math-exp-minus-1-raw x))))) |
40785 | 1128 |
1129 (defun math-exp-minus-1-raw (x) ; [F F] | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1130 (math-exp-series x 2 3 x x)) |
40785 | 1131 |
1132 (defun math-exp-series (sum nfac n xpow x) | |
1133 (math-working "exp" sum) | |
1134 (let* ((nextx (math-mul-float xpow x)) | |
1135 (nextsum (math-add-float sum (math-div-float nextx | |
1136 (math-float nfac))))) | |
1137 (if (math-nearly-equal-float sum nextsum) | |
1138 sum | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1139 (math-exp-series nextsum (math-mul nfac n) (1+ n) nextx x)))) |
40785 | 1140 |
1141 | |
1142 | |
1143 ;;; Logarithms. | |
1144 | |
1145 (defun calcFunc-ln (x) ; [N N] [Public] | |
1146 (cond ((math-zerop x) | |
1147 (if calc-infinite-mode | |
1148 '(neg (var inf var-inf)) | |
1149 (math-reject-arg x "*Logarithm of zero"))) | |
1150 ((eq x 1) 0) | |
1151 ((Math-numberp x) | |
1152 (math-with-extra-prec 2 (math-ln-raw (math-float x)))) | |
1153 ((eq (car-safe x) 'sdev) | |
1154 (math-make-sdev (calcFunc-ln (nth 1 x)) | |
1155 (math-div (nth 2 x) (nth 1 x)))) | |
1156 ((and (eq (car-safe x) 'intv) (or (Math-posp (nth 2 x)) | |
1157 (Math-zerop (nth 2 x)) | |
1158 (not (math-intv-constp x)))) | |
1159 (let ((calc-infinite-mode t)) | |
1160 (math-make-intv (nth 1 x) (calcFunc-ln (nth 2 x)) | |
1161 (calcFunc-ln (nth 3 x))))) | |
1162 ((equal x '(var e var-e)) | |
1163 1) | |
1164 ((and (eq (car-safe x) '^) | |
1165 (equal (nth 1 x) '(var e var-e)) | |
1166 (math-known-realp (nth 2 x))) | |
1167 (nth 2 x)) | |
1168 ((math-infinitep x) | |
1169 (if (equal x '(var nan var-nan)) | |
1170 x | |
1171 '(var inf var-inf))) | |
1172 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1173 (list 'calcFunc-ln x)))) |
40785 | 1174 |
1175 (defun calcFunc-log10 (x) ; [N N] [Public] | |
1176 (cond ((math-equal-int x 1) | |
1177 (if (math-floatp x) '(float 0 0) 0)) | |
1178 ((and (Math-integerp x) | |
1179 (math-posp x) | |
1180 (let ((res (math-integer-log x 10))) | |
1181 (and (car res) | |
1182 (setq x (cdr res))))) | |
1183 x) | |
1184 ((and (eq (car-safe x) 'frac) | |
1185 (eq (nth 1 x) 1) | |
1186 (let ((res (math-integer-log (nth 2 x) 10))) | |
1187 (and (car res) | |
1188 (setq x (- (cdr res)))))) | |
1189 x) | |
1190 ((math-zerop x) | |
1191 (if calc-infinite-mode | |
1192 '(neg (var inf var-inf)) | |
1193 (math-reject-arg x "*Logarithm of zero"))) | |
1194 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1195 ((Math-numberp x) | |
1196 (math-with-extra-prec 2 | |
1197 (let ((xf (math-float x))) | |
1198 (if (eq (nth 1 xf) 0) | |
1199 (math-reject-arg x "*Logarithm of zero")) | |
1200 (if (Math-integer-posp (nth 1 xf)) | |
1201 (if (eq (nth 1 xf) 1) ; log10(1*10^n) = n | |
1202 (math-float (nth 2 xf)) | |
1203 (let ((xdigs (1- (math-numdigs (nth 1 xf))))) | |
1204 (math-add-float | |
1205 (math-div-float (math-ln-raw-2 | |
1206 (list 'float (nth 1 xf) (- xdigs))) | |
1207 (math-ln-10)) | |
1208 (math-float (+ (nth 2 xf) xdigs))))) | |
1209 (math-div (calcFunc-ln xf) (math-ln-10)))))) | |
1210 ((eq (car-safe x) 'sdev) | |
1211 (math-make-sdev (calcFunc-log10 (nth 1 x)) | |
1212 (math-div (nth 2 x) | |
1213 (math-mul (nth 1 x) (math-ln-10))))) | |
1214 ((and (eq (car-safe x) 'intv) (or (Math-posp (nth 2 x)) | |
1215 (not (math-intv-constp x)))) | |
1216 (math-make-intv (nth 1 x) | |
1217 (calcFunc-log10 (nth 2 x)) | |
1218 (calcFunc-log10 (nth 3 x)))) | |
1219 ((math-infinitep x) | |
1220 (if (equal x '(var nan var-nan)) | |
1221 x | |
1222 '(var inf var-inf))) | |
1223 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1224 (list 'calcFunc-log10 x)))) |
40785 | 1225 |
1226 (defun calcFunc-log (x &optional b) ; [N N N] [Public] | |
1227 (cond ((or (null b) (equal b '(var e var-e))) | |
1228 (math-normalize (list 'calcFunc-ln x))) | |
1229 ((or (eq b 10) (equal b '(float 1 1))) | |
1230 (math-normalize (list 'calcFunc-log10 x))) | |
1231 ((math-zerop x) | |
1232 (if calc-infinite-mode | |
1233 (math-div (calcFunc-ln x) (calcFunc-ln b)) | |
1234 (math-reject-arg x "*Logarithm of zero"))) | |
1235 ((math-zerop b) | |
1236 (if calc-infinite-mode | |
1237 (math-div (calcFunc-ln x) (calcFunc-ln b)) | |
1238 (math-reject-arg b "*Logarithm of zero"))) | |
1239 ((math-equal-int b 1) | |
1240 (if calc-infinite-mode | |
1241 (math-div (calcFunc-ln x) 0) | |
1242 (math-reject-arg b "*Logarithm base one"))) | |
1243 ((math-equal-int x 1) | |
1244 (if (or (math-floatp a) (math-floatp b)) '(float 0 0) 0)) | |
1245 ((and (Math-ratp x) (Math-ratp b) | |
1246 (math-posp x) (math-posp b) | |
1247 (let* ((sign 1) (inv nil) | |
1248 (xx (if (Math-lessp 1 x) | |
1249 x | |
1250 (setq sign -1) | |
1251 (math-div 1 x))) | |
1252 (bb (if (Math-lessp 1 b) | |
1253 b | |
1254 (setq sign (- sign)) | |
1255 (math-div 1 b))) | |
1256 (res (if (Math-lessp xx bb) | |
1257 (setq inv (math-integer-log bb xx)) | |
1258 (math-integer-log xx bb)))) | |
1259 (and (car res) | |
1260 (setq x (if inv | |
1261 (math-div 1 (* sign (cdr res))) | |
1262 (* sign (cdr res))))))) | |
1263 x) | |
1264 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1265 ((and (Math-numberp x) (Math-numberp b)) | |
1266 (math-with-extra-prec 2 | |
1267 (math-div (math-ln-raw (math-float x)) | |
1268 (math-log-base-raw b)))) | |
1269 ((and (eq (car-safe x) 'sdev) | |
1270 (Math-numberp b)) | |
1271 (math-make-sdev (calcFunc-log (nth 1 x) b) | |
1272 (math-div (nth 2 x) | |
1273 (math-mul (nth 1 x) | |
1274 (math-log-base-raw b))))) | |
1275 ((and (eq (car-safe x) 'intv) (or (Math-posp (nth 2 x)) | |
1276 (not (math-intv-constp x))) | |
1277 (math-realp b)) | |
1278 (math-make-intv (nth 1 x) | |
1279 (calcFunc-log (nth 2 x) b) | |
1280 (calcFunc-log (nth 3 x) b))) | |
1281 ((or (eq (car-safe x) 'intv) (eq (car-safe b) 'intv)) | |
1282 (math-div (calcFunc-ln x) (calcFunc-ln b))) | |
1283 ((or (math-infinitep x) | |
1284 (math-infinitep b)) | |
1285 (math-div (calcFunc-ln x) (calcFunc-ln b))) | |
1286 (t (if (Math-numberp b) | |
1287 (calc-record-why 'numberp x) | |
1288 (calc-record-why 'numberp b)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1289 (list 'calcFunc-log x b)))) |
40785 | 1290 |
1291 (defun calcFunc-alog (x &optional b) | |
1292 (cond ((or (null b) (equal b '(var e var-e))) | |
1293 (math-normalize (list 'calcFunc-exp x))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1294 (t (math-pow b x)))) |
40785 | 1295 |
1296 (defun calcFunc-ilog (x b) | |
1297 (if (and (math-natnump x) (not (eq x 0)) | |
1298 (math-natnump b) (not (eq b 0))) | |
1299 (if (eq b 1) | |
1300 (math-reject-arg x "*Logarithm base one") | |
1301 (if (Math-natnum-lessp x b) | |
1302 0 | |
1303 (cdr (math-integer-log x b)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1304 (math-floor (calcFunc-log x b)))) |
40785 | 1305 |
1306 (defun math-integer-log (x b) | |
1307 (let ((pows (list b)) | |
1308 (pow (math-sqr b)) | |
1309 next | |
1310 sum n) | |
1311 (while (not (Math-lessp x pow)) | |
1312 (setq pows (cons pow pows) | |
1313 pow (math-sqr pow))) | |
1314 (setq n (lsh 1 (1- (length pows))) | |
1315 sum n | |
1316 pow (car pows)) | |
1317 (while (and (setq pows (cdr pows)) | |
1318 (Math-lessp pow x)) | |
1319 (setq n (/ n 2) | |
1320 next (math-mul pow (car pows))) | |
1321 (or (Math-lessp x next) | |
1322 (setq pow next | |
1323 sum (+ sum n)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1324 (cons (equal pow x) sum))) |
40785 | 1325 |
1326 | |
1327 (defun math-log-base-raw (b) ; [N N] | |
1328 (if (not (and (equal (car math-log-base-cache) b) | |
1329 (eq (nth 1 math-log-base-cache) calc-internal-prec))) | |
1330 (setq math-log-base-cache (list b calc-internal-prec | |
1331 (math-ln-raw (math-float b))))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1332 (nth 2 math-log-base-cache)) |
40785 | 1333 (setq math-log-base-cache nil) |
1334 | |
1335 (defun calcFunc-lnp1 (x) ; [N N] [Public] | |
1336 (cond ((Math-equal-int x -1) | |
1337 (if calc-infinite-mode | |
1338 '(neg (var inf var-inf)) | |
1339 (math-reject-arg x "*Logarithm of zero"))) | |
1340 ((eq x 0) 0) | |
1341 ((math-zerop x) '(float 0 0)) | |
1342 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1343 ((Math-numberp x) | |
1344 (math-with-extra-prec 2 | |
1345 (let ((x (math-float x))) | |
1346 (if (and (eq (car x) 'float) | |
1347 (math-lessp-float x '(float 5 -1)) | |
1348 (math-lessp-float '(float -5 -1) x)) | |
1349 (math-ln-plus-1-raw x) | |
1350 (math-ln-raw (math-add-float x '(float 1 0))))))) | |
1351 ((eq (car-safe x) 'sdev) | |
1352 (math-make-sdev (calcFunc-lnp1 (nth 1 x)) | |
1353 (math-div (nth 2 x) (math-add (nth 1 x) 1)))) | |
1354 ((and (eq (car-safe x) 'intv) (or (Math-posp (nth 2 x)) | |
1355 (not (math-intv-constp x)))) | |
1356 (math-make-intv (nth 1 x) | |
1357 (calcFunc-lnp1 (nth 2 x)) | |
1358 (calcFunc-lnp1 (nth 3 x)))) | |
1359 ((math-infinitep x) | |
1360 (if (equal x '(var nan var-nan)) | |
1361 x | |
1362 '(var inf var-inf))) | |
1363 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1364 (list 'calcFunc-lnp1 x)))) |
40785 | 1365 |
1366 (defun math-ln-raw (x) ; [N N] --- must be float format! | |
1367 (cond ((eq (car-safe x) 'cplx) | |
1368 (list 'cplx | |
1369 (math-mul-float (math-ln-raw | |
1370 (math-add-float (math-sqr-float (nth 1 x)) | |
1371 (math-sqr-float (nth 2 x)))) | |
1372 '(float 5 -1)) | |
1373 (math-arctan2-raw (nth 2 x) (nth 1 x)))) | |
1374 ((eq (car x) 'polar) | |
1375 (math-polar (list 'cplx | |
1376 (math-ln-raw (nth 1 x)) | |
1377 (math-to-radians (nth 2 x))))) | |
1378 ((Math-equal-int x 1) | |
1379 '(float 0 0)) | |
1380 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1381 ((math-posp (nth 1 x)) ; positive and real | |
1382 (let ((xdigs (1- (math-numdigs (nth 1 x))))) | |
1383 (math-add-float (math-ln-raw-2 (list 'float (nth 1 x) (- xdigs))) | |
1384 (math-mul-float (math-float (+ (nth 2 x) xdigs)) | |
1385 (math-ln-10))))) | |
1386 ((math-zerop x) | |
1387 (math-reject-arg x "*Logarithm of zero")) | |
1388 ((eq calc-complex-mode 'polar) ; negative and real | |
1389 (math-polar | |
1390 (list 'cplx ; negative and real | |
1391 (math-ln-raw (math-neg-float x)) | |
1392 (math-pi)))) | |
1393 (t (list 'cplx ; negative and real | |
1394 (math-ln-raw (math-neg-float x)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1395 (math-pi))))) |
40785 | 1396 |
1397 (defun math-ln-raw-2 (x) ; [F F] | |
1398 (cond ((math-lessp-float '(float 14 -1) x) | |
1399 (math-add-float (math-ln-raw-2 (math-mul-float x '(float 5 -1))) | |
1400 (math-ln-2))) | |
1401 (t ; now .7 < x <= 1.4 | |
1402 (math-ln-raw-3 (math-div-float (math-sub-float x '(float 1 0)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1403 (math-add-float x '(float 1 0))))))) |
40785 | 1404 |
1405 (defun math-ln-raw-3 (x) ; [F F] | |
1406 (math-mul-float (math-ln-raw-series x 3 x (math-sqr-float x)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1407 '(float 2 0))) |
40785 | 1408 |
1409 ;;; Compute ln((1+x)/(1-x)) | |
1410 (defun math-ln-raw-series (sum n x xsqr) | |
1411 (math-working "log" sum) | |
1412 (let* ((nextx (math-mul-float x xsqr)) | |
1413 (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) | |
1414 (if (math-nearly-equal-float sum nextsum) | |
1415 sum | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1416 (math-ln-raw-series nextsum (+ n 2) nextx xsqr)))) |
40785 | 1417 |
1418 (defun math-ln-plus-1-raw (x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1419 (math-lnp1-series x 2 x (math-neg x))) |
40785 | 1420 |
1421 (defun math-lnp1-series (sum n xpow x) | |
1422 (math-working "lnp1" sum) | |
1423 (let* ((nextx (math-mul-float xpow x)) | |
1424 (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) | |
1425 (if (math-nearly-equal-float sum nextsum) | |
1426 sum | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1427 (math-lnp1-series nextsum (1+ n) nextx x)))) |
40785 | 1428 |
1429 (math-defcache math-ln-10 (float (bigpos 018 684 045 994 092 585 302 2) -21) | |
1430 (math-ln-raw-2 '(float 1 1))) | |
1431 | |
1432 (math-defcache math-ln-2 (float (bigpos 417 309 945 559 180 147 693) -21) | |
1433 (math-ln-raw-3 (math-float '(frac 1 3)))) | |
1434 | |
1435 | |
1436 | |
1437 ;;; Hyperbolic functions. | |
1438 | |
1439 (defun calcFunc-sinh (x) ; [N N] [Public] | |
1440 (cond ((eq x 0) 0) | |
1441 (math-expand-formulas | |
1442 (math-normalize | |
1443 (list '/ (list '- (list 'calcFunc-exp x) | |
1444 (list 'calcFunc-exp (list 'neg x))) 2))) | |
1445 ((Math-numberp x) | |
1446 (if calc-symbolic-mode (signal 'inexact-result nil)) | |
1447 (math-with-extra-prec 2 | |
1448 (let ((expx (math-exp-raw (math-float x)))) | |
1449 (math-mul (math-add expx (math-div -1 expx)) '(float 5 -1))))) | |
1450 ((eq (car-safe x) 'sdev) | |
1451 (math-make-sdev (calcFunc-sinh (nth 1 x)) | |
1452 (math-mul (nth 2 x) (calcFunc-cosh (nth 1 x))))) | |
1453 ((eq (car x) 'intv) | |
1454 (math-sort-intv (nth 1 x) | |
1455 (calcFunc-sinh (nth 2 x)) | |
1456 (calcFunc-sinh (nth 3 x)))) | |
1457 ((or (equal x '(var inf var-inf)) | |
1458 (equal x '(neg (var inf var-inf))) | |
1459 (equal x '(var nan var-nan))) | |
1460 x) | |
1461 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1462 (list 'calcFunc-sinh x)))) |
40785 | 1463 (put 'calcFunc-sinh 'math-expandable t) |
1464 | |
1465 (defun calcFunc-cosh (x) ; [N N] [Public] | |
1466 (cond ((eq x 0) 1) | |
1467 (math-expand-formulas | |
1468 (math-normalize | |
1469 (list '/ (list '+ (list 'calcFunc-exp x) | |
1470 (list 'calcFunc-exp (list 'neg x))) 2))) | |
1471 ((Math-numberp x) | |
1472 (if calc-symbolic-mode (signal 'inexact-result nil)) | |
1473 (math-with-extra-prec 2 | |
1474 (let ((expx (math-exp-raw (math-float x)))) | |
1475 (math-mul (math-add expx (math-div 1 expx)) '(float 5 -1))))) | |
1476 ((eq (car-safe x) 'sdev) | |
1477 (math-make-sdev (calcFunc-cosh (nth 1 x)) | |
1478 (math-mul (nth 2 x) | |
1479 (calcFunc-sinh (nth 1 x))))) | |
1480 ((and (eq (car x) 'intv) (math-intv-constp x)) | |
1481 (setq x (math-abs x)) | |
1482 (math-sort-intv (nth 1 x) | |
1483 (calcFunc-cosh (nth 2 x)) | |
1484 (calcFunc-cosh (nth 3 x)))) | |
1485 ((or (equal x '(var inf var-inf)) | |
1486 (equal x '(neg (var inf var-inf))) | |
1487 (equal x '(var nan var-nan))) | |
1488 (math-abs x)) | |
1489 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1490 (list 'calcFunc-cosh x)))) |
40785 | 1491 (put 'calcFunc-cosh 'math-expandable t) |
1492 | |
1493 (defun calcFunc-tanh (x) ; [N N] [Public] | |
1494 (cond ((eq x 0) 0) | |
1495 (math-expand-formulas | |
1496 (math-normalize | |
1497 (let ((expx (list 'calcFunc-exp x)) | |
1498 (expmx (list 'calcFunc-exp (list 'neg x)))) | |
1499 (math-normalize | |
1500 (list '/ (list '- expx expmx) (list '+ expx expmx)))))) | |
1501 ((Math-numberp x) | |
1502 (if calc-symbolic-mode (signal 'inexact-result nil)) | |
1503 (math-with-extra-prec 2 | |
1504 (let* ((expx (calcFunc-exp (math-float x))) | |
1505 (expmx (math-div 1 expx))) | |
1506 (math-div (math-sub expx expmx) | |
1507 (math-add expx expmx))))) | |
1508 ((eq (car-safe x) 'sdev) | |
1509 (math-make-sdev (calcFunc-tanh (nth 1 x)) | |
1510 (math-div (nth 2 x) | |
1511 (math-sqr (calcFunc-cosh (nth 1 x)))))) | |
1512 ((eq (car x) 'intv) | |
1513 (math-sort-intv (nth 1 x) | |
1514 (calcFunc-tanh (nth 2 x)) | |
1515 (calcFunc-tanh (nth 3 x)))) | |
1516 ((equal x '(var inf var-inf)) | |
1517 1) | |
1518 ((equal x '(neg (var inf var-inf))) | |
1519 -1) | |
1520 ((equal x '(var nan var-nan)) | |
1521 x) | |
1522 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1523 (list 'calcFunc-tanh x)))) |
40785 | 1524 (put 'calcFunc-tanh 'math-expandable t) |
1525 | |
1526 (defun calcFunc-arcsinh (x) ; [N N] [Public] | |
1527 (cond ((eq x 0) 0) | |
1528 (math-expand-formulas | |
1529 (math-normalize | |
1530 (list 'calcFunc-ln (list '+ x (list 'calcFunc-sqrt | |
1531 (list '+ (list '^ x 2) 1)))))) | |
1532 ((Math-numberp x) | |
1533 (if calc-symbolic-mode (signal 'inexact-result nil)) | |
1534 (math-with-extra-prec 2 | |
1535 (math-ln-raw (math-add x (math-sqrt-raw (math-add (math-sqr x) | |
1536 '(float 1 0))))))) | |
1537 ((eq (car-safe x) 'sdev) | |
1538 (math-make-sdev (calcFunc-arcsinh (nth 1 x)) | |
1539 (math-div (nth 2 x) | |
1540 (math-sqrt | |
1541 (math-add (math-sqr (nth 1 x)) 1))))) | |
1542 ((eq (car x) 'intv) | |
1543 (math-sort-intv (nth 1 x) | |
1544 (calcFunc-arcsinh (nth 2 x)) | |
1545 (calcFunc-arcsinh (nth 3 x)))) | |
1546 ((or (equal x '(var inf var-inf)) | |
1547 (equal x '(neg (var inf var-inf))) | |
1548 (equal x '(var nan var-nan))) | |
1549 x) | |
1550 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1551 (list 'calcFunc-arcsinh x)))) |
40785 | 1552 (put 'calcFunc-arcsinh 'math-expandable t) |
1553 | |
1554 (defun calcFunc-arccosh (x) ; [N N] [Public] | |
1555 (cond ((eq x 1) 0) | |
1556 ((and (eq x -1) calc-symbolic-mode) | |
1557 '(var pi var-pi)) | |
1558 ((and (eq x 0) calc-symbolic-mode) | |
1559 (math-div (math-mul '(var pi var-pi) '(var i var-i)) 2)) | |
1560 (math-expand-formulas | |
1561 (math-normalize | |
1562 (list 'calcFunc-ln (list '+ x (list 'calcFunc-sqrt | |
1563 (list '- (list '^ x 2) 1)))))) | |
1564 ((Math-numberp x) | |
1565 (if calc-symbolic-mode (signal 'inexact-result nil)) | |
1566 (if (Math-equal-int x -1) | |
1567 (math-imaginary (math-pi)) | |
1568 (math-with-extra-prec 2 | |
1569 (if (or t ; need to do this even in the real case! | |
1570 (memq (car-safe x) '(cplx polar))) | |
1571 (let ((xp1 (math-add 1 x))) ; this gets the branch cuts right | |
1572 (math-ln-raw | |
1573 (math-add x (math-mul xp1 | |
1574 (math-sqrt-raw | |
1575 (math-div (math-sub | |
1576 x | |
1577 '(float 1 0)) | |
1578 xp1)))))) | |
1579 (math-ln-raw | |
1580 (math-add x (math-sqrt-raw (math-add (math-sqr x) | |
1581 '(float -1 0))))))))) | |
1582 ((eq (car-safe x) 'sdev) | |
1583 (math-make-sdev (calcFunc-arccosh (nth 1 x)) | |
1584 (math-div (nth 2 x) | |
1585 (math-sqrt | |
1586 (math-add (math-sqr (nth 1 x)) -1))))) | |
1587 ((eq (car x) 'intv) | |
1588 (math-sort-intv (nth 1 x) | |
1589 (calcFunc-arccosh (nth 2 x)) | |
1590 (calcFunc-arccosh (nth 3 x)))) | |
1591 ((or (equal x '(var inf var-inf)) | |
1592 (equal x '(neg (var inf var-inf))) | |
1593 (equal x '(var nan var-nan))) | |
1594 x) | |
1595 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1596 (list 'calcFunc-arccosh x)))) |
40785 | 1597 (put 'calcFunc-arccosh 'math-expandable t) |
1598 | |
1599 (defun calcFunc-arctanh (x) ; [N N] [Public] | |
1600 (cond ((eq x 0) 0) | |
1601 ((and (Math-equal-int x 1) calc-infinite-mode) | |
1602 '(var inf var-inf)) | |
1603 ((and (Math-equal-int x -1) calc-infinite-mode) | |
1604 '(neg (var inf var-inf))) | |
1605 (math-expand-formulas | |
1606 (list '/ (list '- | |
1607 (list 'calcFunc-ln (list '+ 1 x)) | |
1608 (list 'calcFunc-ln (list '- 1 x))) 2)) | |
1609 ((Math-numberp x) | |
1610 (if calc-symbolic-mode (signal 'inexact-result nil)) | |
1611 (math-with-extra-prec 2 | |
1612 (if (or (memq (car-safe x) '(cplx polar)) | |
1613 (Math-lessp 1 x)) | |
1614 (math-mul (math-sub (math-ln-raw (math-add '(float 1 0) x)) | |
1615 (math-ln-raw (math-sub '(float 1 0) x))) | |
1616 '(float 5 -1)) | |
1617 (if (and (math-equal-int x 1) calc-infinite-mode) | |
1618 '(var inf var-inf) | |
1619 (if (and (math-equal-int x -1) calc-infinite-mode) | |
1620 '(neg (var inf var-inf)) | |
1621 (math-mul (math-ln-raw (math-div (math-add '(float 1 0) x) | |
1622 (math-sub 1 x))) | |
1623 '(float 5 -1))))))) | |
1624 ((eq (car-safe x) 'sdev) | |
1625 (math-make-sdev (calcFunc-arctanh (nth 1 x)) | |
1626 (math-div (nth 2 x) | |
1627 (math-sub 1 (math-sqr (nth 1 x)))))) | |
1628 ((eq (car x) 'intv) | |
1629 (math-sort-intv (nth 1 x) | |
1630 (calcFunc-arctanh (nth 2 x)) | |
1631 (calcFunc-arctanh (nth 3 x)))) | |
1632 ((equal x '(var nan var-nan)) | |
1633 x) | |
1634 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1635 (list 'calcFunc-arctanh x)))) |
40785 | 1636 (put 'calcFunc-arctanh 'math-expandable t) |
1637 | |
1638 | |
1639 ;;; Convert A from HMS or degrees to radians. | |
1640 (defun calcFunc-rad (a) ; [R R] [Public] | |
1641 (cond ((or (Math-numberp a) | |
1642 (eq (car a) 'intv)) | |
1643 (math-with-extra-prec 2 | |
1644 (math-mul a (math-pi-over-180)))) | |
1645 ((eq (car a) 'hms) | |
1646 (math-from-hms a 'rad)) | |
1647 ((eq (car a) 'sdev) | |
1648 (math-make-sdev (calcFunc-rad (nth 1 a)) | |
1649 (calcFunc-rad (nth 2 a)))) | |
1650 (math-expand-formulas | |
1651 (math-div (math-mul a '(var pi var-pi)) 180)) | |
1652 ((math-infinitep a) a) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1653 (t (list 'calcFunc-rad a)))) |
40785 | 1654 (put 'calcFunc-rad 'math-expandable t) |
1655 | |
1656 ;;; Convert A from HMS or radians to degrees. | |
1657 (defun calcFunc-deg (a) ; [R R] [Public] | |
1658 (cond ((or (Math-numberp a) | |
1659 (eq (car a) 'intv)) | |
1660 (math-with-extra-prec 2 | |
1661 (math-div a (math-pi-over-180)))) | |
1662 ((eq (car a) 'hms) | |
1663 (math-from-hms a 'deg)) | |
1664 ((eq (car a) 'sdev) | |
1665 (math-make-sdev (calcFunc-deg (nth 1 a)) | |
1666 (calcFunc-deg (nth 2 a)))) | |
1667 (math-expand-formulas | |
1668 (math-div (math-mul 180 a) '(var pi var-pi))) | |
1669 ((math-infinitep a) a) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1670 (t (list 'calcFunc-deg a)))) |
40785 | 1671 (put 'calcFunc-deg 'math-expandable t) |
1672 | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1673 ;;; calc-math.el ends here |
40785 | 1674 |
1675 |