1 |
;; Calculator for GNU Emacs, part II [calc-math.el] |
;; Calculator for GNU Emacs, part II [calc-math.el] |
2 |
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. |
;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
3 |
;; Written by Dave Gillespie, daveg@synaptics.com. |
;; Written by Dave Gillespie, daveg@synaptics.com. |
4 |
|
|
5 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
34 |
(calc-slow-wrapper |
(calc-slow-wrapper |
35 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
36 |
(calc-unary-op "^2" 'calcFunc-sqr arg) |
(calc-unary-op "^2" 'calcFunc-sqr arg) |
37 |
(calc-unary-op "sqrt" 'calcFunc-sqrt arg))) |
(calc-unary-op "sqrt" 'calcFunc-sqrt arg)))) |
|
) |
|
38 |
|
|
39 |
(defun calc-isqrt (arg) |
(defun calc-isqrt (arg) |
40 |
(interactive "P") |
(interactive "P") |
41 |
(calc-slow-wrapper |
(calc-slow-wrapper |
42 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
43 |
(calc-unary-op "^2" 'calcFunc-sqr arg) |
(calc-unary-op "^2" 'calcFunc-sqr arg) |
44 |
(calc-unary-op "isqt" 'calcFunc-isqrt arg))) |
(calc-unary-op "isqt" 'calcFunc-isqrt arg)))) |
|
) |
|
45 |
|
|
46 |
|
|
47 |
(defun calc-hypot (arg) |
(defun calc-hypot (arg) |
48 |
(interactive "P") |
(interactive "P") |
49 |
(calc-slow-wrapper |
(calc-slow-wrapper |
50 |
(calc-binary-op "hypt" 'calcFunc-hypot arg)) |
(calc-binary-op "hypt" 'calcFunc-hypot arg))) |
|
) |
|
51 |
|
|
52 |
(defun calc-ln (arg) |
(defun calc-ln (arg) |
53 |
(interactive "P") |
(interactive "P") |
54 |
(calc-invert-func) |
(calc-invert-func) |
55 |
(calc-exp arg) |
(calc-exp arg)) |
|
) |
|
56 |
|
|
57 |
(defun calc-log10 (arg) |
(defun calc-log10 (arg) |
58 |
(interactive "P") |
(interactive "P") |
59 |
(calc-hyperbolic-func) |
(calc-hyperbolic-func) |
60 |
(calc-ln arg) |
(calc-ln arg)) |
|
) |
|
61 |
|
|
62 |
(defun calc-log (arg) |
(defun calc-log (arg) |
63 |
(interactive "P") |
(interactive "P") |
64 |
(calc-slow-wrapper |
(calc-slow-wrapper |
65 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
66 |
(calc-binary-op "alog" 'calcFunc-alog arg) |
(calc-binary-op "alog" 'calcFunc-alog arg) |
67 |
(calc-binary-op "log" 'calcFunc-log arg))) |
(calc-binary-op "log" 'calcFunc-log arg)))) |
|
) |
|
68 |
|
|
69 |
(defun calc-ilog (arg) |
(defun calc-ilog (arg) |
70 |
(interactive "P") |
(interactive "P") |
71 |
(calc-slow-wrapper |
(calc-slow-wrapper |
72 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
73 |
(calc-binary-op "alog" 'calcFunc-alog arg) |
(calc-binary-op "alog" 'calcFunc-alog arg) |
74 |
(calc-binary-op "ilog" 'calcFunc-ilog arg))) |
(calc-binary-op "ilog" 'calcFunc-ilog arg)))) |
|
) |
|
75 |
|
|
76 |
(defun calc-lnp1 (arg) |
(defun calc-lnp1 (arg) |
77 |
(interactive "P") |
(interactive "P") |
78 |
(calc-invert-func) |
(calc-invert-func) |
79 |
(calc-expm1 arg) |
(calc-expm1 arg)) |
|
) |
|
80 |
|
|
81 |
(defun calc-exp (arg) |
(defun calc-exp (arg) |
82 |
(interactive "P") |
(interactive "P") |
87 |
(calc-unary-op "10^" 'calcFunc-exp10 arg)) |
(calc-unary-op "10^" 'calcFunc-exp10 arg)) |
88 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
89 |
(calc-unary-op "ln" 'calcFunc-ln arg) |
(calc-unary-op "ln" 'calcFunc-ln arg) |
90 |
(calc-unary-op "exp" 'calcFunc-exp arg)))) |
(calc-unary-op "exp" 'calcFunc-exp arg))))) |
|
) |
|
91 |
|
|
92 |
(defun calc-expm1 (arg) |
(defun calc-expm1 (arg) |
93 |
(interactive "P") |
(interactive "P") |
94 |
(calc-slow-wrapper |
(calc-slow-wrapper |
95 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
96 |
(calc-unary-op "ln+1" 'calcFunc-lnp1 arg) |
(calc-unary-op "ln+1" 'calcFunc-lnp1 arg) |
97 |
(calc-unary-op "ex-1" 'calcFunc-expm1 arg))) |
(calc-unary-op "ex-1" 'calcFunc-expm1 arg)))) |
|
) |
|
98 |
|
|
99 |
(defun calc-pi () |
(defun calc-pi () |
100 |
(interactive) |
(interactive) |
113 |
(calc-pop-push-record 0 "e" (math-e))) |
(calc-pop-push-record 0 "e" (math-e))) |
114 |
(if calc-symbolic-mode |
(if calc-symbolic-mode |
115 |
(calc-pop-push-record 0 "pi" '(var pi var-pi)) |
(calc-pop-push-record 0 "pi" '(var pi var-pi)) |
116 |
(calc-pop-push-record 0 "pi" (math-pi)))))) |
(calc-pop-push-record 0 "pi" (math-pi))))))) |
|
) |
|
117 |
|
|
118 |
(defun calc-sin (arg) |
(defun calc-sin (arg) |
119 |
(interactive "P") |
(interactive "P") |
124 |
(calc-unary-op "sinh" 'calcFunc-sinh arg)) |
(calc-unary-op "sinh" 'calcFunc-sinh arg)) |
125 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
126 |
(calc-unary-op "asin" 'calcFunc-arcsin arg) |
(calc-unary-op "asin" 'calcFunc-arcsin arg) |
127 |
(calc-unary-op "sin" 'calcFunc-sin arg)))) |
(calc-unary-op "sin" 'calcFunc-sin arg))))) |
|
) |
|
128 |
|
|
129 |
(defun calc-arcsin (arg) |
(defun calc-arcsin (arg) |
130 |
(interactive "P") |
(interactive "P") |
131 |
(calc-invert-func) |
(calc-invert-func) |
132 |
(calc-sin arg) |
(calc-sin arg)) |
|
) |
|
133 |
|
|
134 |
(defun calc-sinh (arg) |
(defun calc-sinh (arg) |
135 |
(interactive "P") |
(interactive "P") |
136 |
(calc-hyperbolic-func) |
(calc-hyperbolic-func) |
137 |
(calc-sin arg) |
(calc-sin arg)) |
|
) |
|
138 |
|
|
139 |
(defun calc-arcsinh (arg) |
(defun calc-arcsinh (arg) |
140 |
(interactive "P") |
(interactive "P") |
141 |
(calc-invert-func) |
(calc-invert-func) |
142 |
(calc-hyperbolic-func) |
(calc-hyperbolic-func) |
143 |
(calc-sin arg) |
(calc-sin arg)) |
|
) |
|
144 |
|
|
145 |
(defun calc-cos (arg) |
(defun calc-cos (arg) |
146 |
(interactive "P") |
(interactive "P") |
151 |
(calc-unary-op "cosh" 'calcFunc-cosh arg)) |
(calc-unary-op "cosh" 'calcFunc-cosh arg)) |
152 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
153 |
(calc-unary-op "acos" 'calcFunc-arccos arg) |
(calc-unary-op "acos" 'calcFunc-arccos arg) |
154 |
(calc-unary-op "cos" 'calcFunc-cos arg)))) |
(calc-unary-op "cos" 'calcFunc-cos arg))))) |
|
) |
|
155 |
|
|
156 |
(defun calc-arccos (arg) |
(defun calc-arccos (arg) |
157 |
(interactive "P") |
(interactive "P") |
158 |
(calc-invert-func) |
(calc-invert-func) |
159 |
(calc-cos arg) |
(calc-cos arg)) |
|
) |
|
160 |
|
|
161 |
(defun calc-cosh (arg) |
(defun calc-cosh (arg) |
162 |
(interactive "P") |
(interactive "P") |
163 |
(calc-hyperbolic-func) |
(calc-hyperbolic-func) |
164 |
(calc-cos arg) |
(calc-cos arg)) |
|
) |
|
165 |
|
|
166 |
(defun calc-arccosh (arg) |
(defun calc-arccosh (arg) |
167 |
(interactive "P") |
(interactive "P") |
168 |
(calc-invert-func) |
(calc-invert-func) |
169 |
(calc-hyperbolic-func) |
(calc-hyperbolic-func) |
170 |
(calc-cos arg) |
(calc-cos arg)) |
|
) |
|
171 |
|
|
172 |
(defun calc-sincos () |
(defun calc-sincos () |
173 |
(interactive) |
(interactive) |
174 |
(calc-slow-wrapper |
(calc-slow-wrapper |
175 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
176 |
(calc-enter-result 1 "asnc" (list 'calcFunc-arcsincos (calc-top-n 1))) |
(calc-enter-result 1 "asnc" (list 'calcFunc-arcsincos (calc-top-n 1))) |
177 |
(calc-enter-result 1 "sncs" (list 'calcFunc-sincos (calc-top-n 1))))) |
(calc-enter-result 1 "sncs" (list 'calcFunc-sincos (calc-top-n 1)))))) |
|
) |
|
178 |
|
|
179 |
(defun calc-tan (arg) |
(defun calc-tan (arg) |
180 |
(interactive "P") |
(interactive "P") |
185 |
(calc-unary-op "tanh" 'calcFunc-tanh arg)) |
(calc-unary-op "tanh" 'calcFunc-tanh arg)) |
186 |
(if (calc-is-inverse) |
(if (calc-is-inverse) |
187 |
(calc-unary-op "atan" 'calcFunc-arctan arg) |
(calc-unary-op "atan" 'calcFunc-arctan arg) |
188 |
(calc-unary-op "tan" 'calcFunc-tan arg)))) |
(calc-unary-op "tan" 'calcFunc-tan arg))))) |
|
) |
|
189 |
|
|
190 |
(defun calc-arctan (arg) |
(defun calc-arctan (arg) |
191 |
(interactive "P") |
(interactive "P") |
192 |
(calc-invert-func) |
(calc-invert-func) |
193 |
(calc-tan arg) |
(calc-tan arg)) |
|
) |
|
194 |
|
|
195 |
(defun calc-tanh (arg) |
(defun calc-tanh (arg) |
196 |
(interactive "P") |
(interactive "P") |
197 |
(calc-hyperbolic-func) |
(calc-hyperbolic-func) |
198 |
(calc-tan arg) |
(calc-tan arg)) |
|
) |
|
199 |
|
|
200 |
(defun calc-arctanh (arg) |
(defun calc-arctanh (arg) |
201 |
(interactive "P") |
(interactive "P") |
202 |
(calc-invert-func) |
(calc-invert-func) |
203 |
(calc-hyperbolic-func) |
(calc-hyperbolic-func) |
204 |
(calc-tan arg) |
(calc-tan arg)) |
|
) |
|
205 |
|
|
206 |
(defun calc-arctan2 () |
(defun calc-arctan2 () |
207 |
(interactive) |
(interactive) |
208 |
(calc-slow-wrapper |
(calc-slow-wrapper |
209 |
(calc-enter-result 2 "atn2" (cons 'calcFunc-arctan2 (calc-top-list-n 2)))) |
(calc-enter-result 2 "atn2" (cons 'calcFunc-arctan2 (calc-top-list-n 2))))) |
|
) |
|
210 |
|
|
211 |
(defun calc-conj (arg) |
(defun calc-conj (arg) |
212 |
(interactive "P") |
(interactive "P") |
213 |
(calc-wrapper |
(calc-wrapper |
214 |
(calc-unary-op "conj" 'calcFunc-conj arg)) |
(calc-unary-op "conj" 'calcFunc-conj arg))) |
|
) |
|
215 |
|
|
216 |
(defun calc-imaginary () |
(defun calc-imaginary () |
217 |
(interactive) |
(interactive) |
218 |
(calc-slow-wrapper |
(calc-slow-wrapper |
219 |
(calc-pop-push-record 1 "i*" (math-imaginary (calc-top-n 1)))) |
(calc-pop-push-record 1 "i*" (math-imaginary (calc-top-n 1))))) |
|
) |
|
220 |
|
|
221 |
|
|
222 |
|
|
223 |
(defun calc-to-degrees (arg) |
(defun calc-to-degrees (arg) |
224 |
(interactive "P") |
(interactive "P") |
225 |
(calc-wrapper |
(calc-wrapper |
226 |
(calc-unary-op ">deg" 'calcFunc-deg arg)) |
(calc-unary-op ">deg" 'calcFunc-deg arg))) |
|
) |
|
227 |
|
|
228 |
(defun calc-to-radians (arg) |
(defun calc-to-radians (arg) |
229 |
(interactive "P") |
(interactive "P") |
230 |
(calc-wrapper |
(calc-wrapper |
231 |
(calc-unary-op ">rad" 'calcFunc-rad arg)) |
(calc-unary-op ">rad" 'calcFunc-rad arg))) |
|
) |
|
232 |
|
|
233 |
|
|
234 |
(defun calc-degrees-mode (arg) |
(defun calc-degrees-mode (arg) |
239 |
(message "Angles measured in degrees."))) |
(message "Angles measured in degrees."))) |
240 |
((= arg 2) (calc-radians-mode)) |
((= arg 2) (calc-radians-mode)) |
241 |
((= arg 3) (calc-hms-mode)) |
((= arg 3) (calc-hms-mode)) |
242 |
(t (error "Prefix argument out of range"))) |
(t (error "Prefix argument out of range")))) |
|
) |
|
243 |
|
|
244 |
(defun calc-radians-mode () |
(defun calc-radians-mode () |
245 |
(interactive) |
(interactive) |
246 |
(calc-wrapper |
(calc-wrapper |
247 |
(calc-change-mode 'calc-angle-mode 'rad) |
(calc-change-mode 'calc-angle-mode 'rad) |
248 |
(message "Angles measured in radians.")) |
(message "Angles measured in radians."))) |
|
) |
|
249 |
|
|
250 |
|
|
251 |
;;; Compute the integer square-root floor(sqrt(A)). A > 0. [I I] [Public] |
;;; Compute the integer square-root floor(sqrt(A)). A > 0. [I I] [Public] |
258 |
((integerp a) |
((integerp a) |
259 |
(math-isqrt-small a)) |
(math-isqrt-small a)) |
260 |
(t |
(t |
261 |
(math-normalize (cons 'bigpos (cdr (math-isqrt-bignum (cdr a))))))) |
(math-normalize (cons 'bigpos (cdr (math-isqrt-bignum (cdr a)))))))) |
|
) |
|
262 |
|
|
263 |
(defun calcFunc-isqrt (a) |
(defun calcFunc-isqrt (a) |
264 |
(if (math-realp a) |
(if (math-realp a) |
265 |
(math-isqrt (math-floor a)) |
(math-isqrt (math-floor a)) |
266 |
(math-floor (math-sqrt a))) |
(math-floor (math-sqrt a)))) |
|
) |
|
267 |
|
|
268 |
|
|
269 |
;;; This returns (flag . result) where the flag is T if A is a perfect square. |
;;; This returns (flag . result) where the flag is T if A is a perfect square. |
283 |
a |
a |
284 |
(math-scale-bignum-3 |
(math-scale-bignum-3 |
285 |
(list (1+ (math-isqrt-small top))) |
(list (1+ (math-isqrt-small top))) |
286 |
(/ len 2)))))) |
(/ len 2))))))) |
|
) |
|
287 |
|
|
288 |
(defun math-isqrt-bignum-iter (a guess) ; [l L l] |
(defun math-isqrt-bignum-iter (a guess) ; [l L l] |
289 |
(math-working "isqrt" (cons 'bigpos guess)) |
(math-working "isqrt" (cons 'bigpos guess)) |
296 |
(cons (and (= comp 0) |
(cons (and (= comp 0) |
297 |
(math-zerop-bignum (cdr q)) |
(math-zerop-bignum (cdr q)) |
298 |
(= (% (car s) 2) 0)) |
(= (% (car s) 2) 0)) |
299 |
guess))) |
guess)))) |
|
) |
|
300 |
|
|
301 |
(defun math-zerop-bignum (a) |
(defun math-zerop-bignum (a) |
302 |
(and (eq (car a) 0) |
(and (eq (car a) 0) |
303 |
(progn |
(progn |
304 |
(while (eq (car (setq a (cdr a))) 0)) |
(while (eq (car (setq a (cdr a))) 0)) |
305 |
(null a))) |
(null a)))) |
|
) |
|
306 |
|
|
307 |
(defun math-scale-bignum-3 (a n) ; [L L S] |
(defun math-scale-bignum-3 (a n) ; [L L S] |
308 |
(while (> n 0) |
(while (> n 0) |
309 |
(setq a (cons 0 a) |
(setq a (cons 0 a) |
310 |
n (1- n))) |
n (1- n))) |
311 |
a |
a) |
|
) |
|
312 |
|
|
313 |
(defun math-isqrt-small (a) ; A > 0. [S S] |
(defun math-isqrt-small (a) ; A > 0. [S S] |
314 |
(let ((g (cond ((>= a 10000) 1000) |
(let ((g (cond ((>= a 10000) 1000) |
317 |
g2) |
g2) |
318 |
(while (< (setq g2 (/ (+ g (/ a g)) 2)) g) |
(while (< (setq g2 (/ (+ g (/ a g)) 2)) g) |
319 |
(setq g g2)) |
(setq g g2)) |
320 |
g) |
g)) |
|
) |
|
321 |
|
|
322 |
|
|
323 |
|
|
411 |
(math-mul (math-sqrt (math-infinite-dir a inf)) inf))) |
(math-mul (math-sqrt (math-infinite-dir a inf)) inf))) |
412 |
(progn |
(progn |
413 |
(calc-record-why 'numberp a) |
(calc-record-why 'numberp a) |
414 |
(list 'calcFunc-sqrt a))) |
(list 'calcFunc-sqrt a)))) |
415 |
) |
(defalias calcFunc-sqrt 'math-sqrt) |
|
(fset 'calcFunc-sqrt (symbol-function 'math-sqrt)) |
|
416 |
|
|
417 |
(defun math-infinite-dir (a &optional inf) |
(defun math-infinite-dir (a &optional inf) |
418 |
(or inf (setq inf (math-infinitep a))) |
(or inf (setq inf (math-infinitep a))) |
419 |
(math-normalize (math-expr-subst a inf 1)) |
(math-normalize (math-expr-subst a inf 1))) |
|
) |
|
420 |
|
|
421 |
(defun math-sqrt-float (a &optional guess) ; [F F F] |
(defun math-sqrt-float (a &optional guess) ; [F F F] |
422 |
(if calc-symbolic-mode |
(if calc-symbolic-mode |
423 |
(signal 'inexact-result nil) |
(signal 'inexact-result nil) |
424 |
(math-with-extra-prec 1 (math-sqrt-raw a guess))) |
(math-with-extra-prec 1 (math-sqrt-raw a guess)))) |
|
) |
|
425 |
|
|
426 |
(defun math-sqrt-raw (a &optional guess) ; [F F F] |
(defun math-sqrt-raw (a &optional guess) ; [F F F] |
427 |
(if (not (Math-posp a)) |
(if (not (Math-posp a)) |
432 |
(setq guess (math-make-float (math-isqrt-small |
(setq guess (math-make-float (math-isqrt-small |
433 |
(math-scale-int (nth 1 a) (- ldiff))) |
(math-scale-int (nth 1 a) (- ldiff))) |
434 |
(/ (+ (nth 2 a) ldiff) 2))))) |
(/ (+ (nth 2 a) ldiff) 2))))) |
435 |
(math-sqrt-float-iter a guess)) |
(math-sqrt-float-iter a guess))) |
|
) |
|
436 |
|
|
437 |
(defun math-sqrt-float-iter (a guess) ; [F F F] |
(defun math-sqrt-float-iter (a guess) ; [F F F] |
438 |
(math-working "sqrt" guess) |
(math-working "sqrt" guess) |
440 |
'(float 5 -1)))) |
'(float 5 -1)))) |
441 |
(if (math-nearly-equal-float g2 guess) |
(if (math-nearly-equal-float g2 guess) |
442 |
g2 |
g2 |
443 |
(math-sqrt-float-iter a g2))) |
(math-sqrt-float-iter a g2)))) |
|
) |
|
444 |
|
|
445 |
;;; True if A and B differ only in the last digit of precision. [P F F] |
;;; True if A and B differ only in the last digit of precision. [P F F] |
446 |
(defun math-nearly-equal-float (a b) |
(defun math-nearly-equal-float (a b) |
465 |
(and (not (consp ediff)) |
(and (not (consp ediff)) |
466 |
(< ediff 10) |
(< ediff 10) |
467 |
(> ediff -10) |
(> ediff -10) |
468 |
(= (math-numdigs (nth 1 a)) calc-internal-prec))))) |
(= (math-numdigs (nth 1 a)) calc-internal-prec)))))) |
|
) |
|
469 |
|
|
470 |
(defun math-nearly-equal (a b) ; [P N N] [Public] |
(defun math-nearly-equal (a b) ; [P N N] [Public] |
471 |
(setq a (math-float a)) |
(setq a (math-float a)) |
485 |
(if (eq (car b) 'cplx) |
(if (eq (car b) 'cplx) |
486 |
(and (math-nearly-equal-float a (nth 1 b)) |
(and (math-nearly-equal-float a (nth 1 b)) |
487 |
(math-nearly-zerop-float a (nth 2 b))) |
(math-nearly-zerop-float a (nth 2 b))) |
488 |
(math-nearly-equal-float a b))) |
(math-nearly-equal-float a b)))) |
|
) |
|
489 |
|
|
490 |
;;; True if A is nearly zero compared to B. [P F F] |
;;; True if A is nearly zero compared to B. [P F F] |
491 |
(defun math-nearly-zerop-float (a b) |
(defun math-nearly-zerop-float (a b) |
492 |
(or (eq (nth 1 a) 0) |
(or (eq (nth 1 a) 0) |
493 |
(<= (+ (math-numdigs (nth 1 a)) (nth 2 a)) |
(<= (+ (math-numdigs (nth 1 a)) (nth 2 a)) |
494 |
(1+ (- (+ (math-numdigs (nth 1 b)) (nth 2 b)) calc-internal-prec)))) |
(1+ (- (+ (math-numdigs (nth 1 b)) (nth 2 b)) calc-internal-prec))))) |
|
) |
|
495 |
|
|
496 |
(defun math-nearly-zerop (a b) ; [P N R] [Public] |
(defun math-nearly-zerop (a b) ; [P N R] [Public] |
497 |
(setq a (math-float a)) |
(setq a (math-float a)) |
501 |
(math-nearly-zerop-float (nth 2 a) b)) |
(math-nearly-zerop-float (nth 2 a) b)) |
502 |
(if (eq (car a) 'polar) |
(if (eq (car a) 'polar) |
503 |
(math-nearly-zerop-float (nth 1 a) b) |
(math-nearly-zerop-float (nth 1 a) b) |
504 |
(math-nearly-zerop-float a b))) |
(math-nearly-zerop-float a b)))) |
|
) |
|
505 |
|
|
506 |
;;; This implementation could be improved, accuracy-wise. |
;;; This implementation could be improved, accuracy-wise. |
507 |
(defun math-hypot (a b) |
(defun math-hypot (a b) |
531 |
(math-to-hms (math-hypot (math-from-hms a 'deg) b)))) |
(math-to-hms (math-hypot (math-from-hms a 'deg) b)))) |
532 |
((eq (car-safe b) 'hms) |
((eq (car-safe b) 'hms) |
533 |
(math-to-hms (math-hypot a (math-from-hms b 'deg)))) |
(math-to-hms (math-hypot a (math-from-hms b 'deg)))) |
534 |
(t nil)) |
(t nil))) |
535 |
) |
(defalias calcFunc-hypot 'math-hypot) |
|
(fset 'calcFunc-hypot (symbol-function 'math-hypot)) |
|
536 |
|
|
537 |
(defun calcFunc-sqr (x) |
(defun calcFunc-sqr (x) |
538 |
(math-pow x 2) |
(math-pow x 2)) |
|
) |
|
539 |
|
|
540 |
|
|
541 |
|
|
566 |
((eq (car-safe a) 'polar) |
((eq (car-safe a) 'polar) |
567 |
(let ((root (math-nth-root (nth 1 a) n))) |
(let ((root (math-nth-root (nth 1 a) n))) |
568 |
(and root (list 'polar root (math-div (nth 2 a) n))))) |
(and root (list 'polar root (math-div (nth 2 a) n))))) |
569 |
(t nil)) |
(t nil))) |
|
) |
|
570 |
|
|
571 |
(defun math-nth-root-float (a n &optional guess) |
(defun math-nth-root-float (a n &optional guess) |
572 |
(math-inexact-result) |
(math-inexact-result) |
578 |
1 (/ (+ (math-numdigs (nth 1 a)) |
1 (/ (+ (math-numdigs (nth 1 a)) |
579 |
(nth 2 a) |
(nth 2 a) |
580 |
(/ n 2)) |
(/ n 2)) |
581 |
n)))))) |
n))))))) |
|
) |
|
582 |
|
|
583 |
(defun math-nth-root-float-iter (a guess) ; uses "n", "nf", "nfm1" |
(defun math-nth-root-float-iter (a guess) ; uses "n", "nf", "nfm1" |
584 |
(math-working "root" guess) |
(math-working "root" guess) |
588 |
nf))) |
nf))) |
589 |
(if (math-nearly-equal-float g2 guess) |
(if (math-nearly-equal-float g2 guess) |
590 |
g2 |
g2 |
591 |
(math-nth-root-float-iter a g2))) |
(math-nth-root-float-iter a g2)))) |
|
) |
|
592 |
|
|
593 |
(defun math-nth-root-integer (a n &optional guess) ; [I I S] |
(defun math-nth-root-integer (a n &optional guess) ; [I I S] |
594 |
(math-nth-root-int-iter a (or guess |
(math-nth-root-int-iter a (or guess |
595 |
(math-scale-int 1 (/ (+ (math-numdigs a) |
(math-scale-int 1 (/ (+ (math-numdigs a) |
596 |
(1- n)) |
(1- n)) |
597 |
n)))) |
n))))) |
|
) |
|
598 |
|
|
599 |
(defun math-nth-root-int-iter (a guess) ; uses "n" |
(defun math-nth-root-int-iter (a guess) ; uses "n" |
600 |
(math-working "root" guess) |
(math-working "root" guess) |
606 |
(cons (and (equal (car g2) guess) |
(cons (and (equal (car g2) guess) |
607 |
(eq (cdr q) 0) |
(eq (cdr q) 0) |
608 |
(eq (cdr g2) 0)) |
(eq (cdr g2) 0)) |
609 |
guess))) |
guess)))) |
|
) |
|
610 |
|
|
611 |
(defun calcFunc-nroot (x n) |
(defun calcFunc-nroot (x n) |
612 |
(calcFunc-pow x (if (integerp n) |
(calcFunc-pow x (if (integerp n) |
613 |
(math-make-frac 1 n) |
(math-make-frac 1 n) |
614 |
(math-div 1 n))) |
(math-div 1 n)))) |
|
) |
|
615 |
|
|
616 |
|
|
617 |
|
|
631 |
(math-from-hms a 'rad)) |
(math-from-hms a 'rad)) |
632 |
((memq calc-angle-mode '(deg hms)) |
((memq calc-angle-mode '(deg hms)) |
633 |
(math-mul a (math-pi-over-180))) |
(math-mul a (math-pi-over-180))) |
634 |
(t a)) |
(t a))) |
|
) |
|
635 |
|
|
636 |
(defun math-from-radians (a) ; [N N] |
(defun math-from-radians (a) ; [N N] |
637 |
(cond ((eq calc-angle-mode 'deg) |
(cond ((eq calc-angle-mode 'deg) |
640 |
(list 'calcFunc-deg a))) |
(list 'calcFunc-deg a))) |
641 |
((eq calc-angle-mode 'hms) |
((eq calc-angle-mode 'hms) |
642 |
(math-to-hms a 'rad)) |
(math-to-hms a 'rad)) |
643 |
(t a)) |
(t a))) |
|
) |
|
644 |
|
|
645 |
(defun math-to-radians-2 (a) ; [N N] |
(defun math-to-radians-2 (a) ; [N N] |
646 |
(cond ((eq (car-safe a) 'hms) |
(cond ((eq (car-safe a) 'hms) |
649 |
(if calc-symbolic-mode |
(if calc-symbolic-mode |
650 |
(math-div (math-mul a '(var pi var-pi)) 180) |
(math-div (math-mul a '(var pi var-pi)) 180) |
651 |
(math-mul a (math-pi-over-180)))) |
(math-mul a (math-pi-over-180)))) |
652 |
(t a)) |
(t a))) |
|
) |
|
653 |
|
|
654 |
(defun math-from-radians-2 (a) ; [N N] |
(defun math-from-radians-2 (a) ; [N N] |
655 |
(cond ((memq calc-angle-mode '(deg hms)) |
(cond ((memq calc-angle-mode '(deg hms)) |
656 |
(if calc-symbolic-mode |
(if calc-symbolic-mode |
657 |
(math-div (math-mul 180 a) '(var pi var-pi)) |
(math-div (math-mul 180 a) '(var pi var-pi)) |
658 |
(math-div a (math-pi-over-180)))) |
(math-div a (math-pi-over-180)))) |
659 |
(t a)) |
(t a))) |
|
) |
|
660 |
|
|
661 |
|
|
662 |
|
|
685 |
((equal x '(var nan var-nan)) |
((equal x '(var nan var-nan)) |
686 |
x) |
x) |
687 |
(t (calc-record-why 'scalarp x) |
(t (calc-record-why 'scalarp x) |
688 |
(list 'calcFunc-sin x))) |
(list 'calcFunc-sin x)))) |
|
) |
|
689 |
|
|
690 |
(defun calcFunc-cos (x) ; [N N] [Public] |
(defun calcFunc-cos (x) ; [N N] [Public] |
691 |
(cond ((and (integerp x) |
(cond ((and (integerp x) |
728 |
((equal x '(var nan var-nan)) |
((equal x '(var nan var-nan)) |
729 |
x) |
x) |
730 |
(t (calc-record-why 'scalarp x) |
(t (calc-record-why 'scalarp x) |
731 |
(list 'calcFunc-cos x))) |
(list 'calcFunc-cos x)))) |
|
) |
|
732 |
|
|
733 |
(defun calcFunc-sincos (x) ; [V N] [Public] |
(defun calcFunc-sincos (x) ; [V N] [Public] |
734 |
(if (Math-scalarp x) |
(if (Math-scalarp x) |
735 |
(math-with-extra-prec 2 |
(math-with-extra-prec 2 |
736 |
(let ((sc (math-sin-cos-raw (math-to-radians (math-float x))))) |
(let ((sc (math-sin-cos-raw (math-to-radians (math-float x))))) |
737 |
(list 'vec (cdr sc) (car sc)))) ; the vector [cos, sin] |
(list 'vec (cdr sc) (car sc)))) ; the vector [cos, sin] |
738 |
(list 'vec (calcFunc-sin x) (calcFunc-cos x))) |
(list 'vec (calcFunc-sin x) (calcFunc-cos x)))) |
|
) |
|
739 |
|
|
740 |
(defun calcFunc-tan (x) ; [N N] [Public] |
(defun calcFunc-tan (x) ; [N N] [Public] |
741 |
(cond ((and (integerp x) |
(cond ((and (integerp x) |
778 |
((equal x '(var nan var-nan)) |
((equal x '(var nan var-nan)) |
779 |
x) |
x) |
780 |
(t (calc-record-why 'scalarp x) |
(t (calc-record-why 'scalarp x) |
781 |
(list 'calcFunc-tan x))) |
(list 'calcFunc-tan x)))) |
|
) |
|
782 |
|
|
783 |
(defun math-sin-raw (x) ; [N N] |
(defun math-sin-raw (x) ; [N N] |
784 |
(cond ((eq (car x) 'cplx) |
(cond ((eq (car x) 'cplx) |
798 |
(math-neg-float (math-sin-raw (math-neg-float x)))) |
(math-neg-float (math-sin-raw (math-neg-float x)))) |
799 |
((math-lessp-float '(float 7 0) x) ; avoid inf loops due to roundoff |
((math-lessp-float '(float 7 0) x) ; avoid inf loops due to roundoff |
800 |
(math-sin-raw (math-mod x (math-two-pi)))) |
(math-sin-raw (math-mod x (math-two-pi)))) |
801 |
(t (math-sin-raw-2 x x))) |
(t (math-sin-raw-2 x x)))) |
|
) |
|
802 |
|
|
803 |
(defun math-cos-raw (x) ; [N N] |
(defun math-cos-raw (x) ; [N N] |
804 |
(if (eq (car-safe x) 'polar) |
(if (eq (car-safe x) 'polar) |
805 |
(math-polar (math-cos-raw (math-complex x))) |
(math-polar (math-cos-raw (math-complex x))) |
806 |
(math-sin-raw (math-sub (math-pi-over-2) x))) |
(math-sin-raw (math-sub (math-pi-over-2) x)))) |
|
) |
|
807 |
|
|
808 |
;;; This could use a smarter method: Reduce x as in math-sin-raw, then |
;;; 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 |
;;; 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. |
;;; 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)) |
(defun math-sin-cos-raw (x) ; [F.F F] (result is (sin x . cos x)) |
812 |
(cons (math-sin-raw x) (math-cos-raw x)) |
(cons (math-sin-raw x) (math-cos-raw x))) |
|
) |
|
813 |
|
|
814 |
(defun math-tan-raw (x) ; [N N] |
(defun math-tan-raw (x) ; [N N] |
815 |
(cond ((eq (car x) 'cplx) |
(cond ((eq (car x) 'cplx) |
832 |
(let ((sc (math-sin-cos-raw x))) |
(let ((sc (math-sin-cos-raw x))) |
833 |
(if (eq (nth 1 (cdr sc)) 0) |
(if (eq (nth 1 (cdr sc)) 0) |
834 |
(math-div (car sc) 0) |
(math-div (car sc) 0) |
835 |
(math-div-float (car sc) (cdr sc)))))) |
(math-div-float (car sc) (cdr sc))))))) |
|
) |
|
836 |
|
|
837 |
(defun math-sin-raw-2 (x orgx) ; This avoids poss of inf recursion. [F F] |
(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))) |
(let ((xmpo2 (math-sub-float (math-pi-over-2) x))) |
845 |
(math-neg (math-cos-raw-2 (math-add (math-pi-over-2) x) orgx))) |
(math-neg (math-cos-raw-2 (math-add (math-pi-over-2) x) orgx))) |
846 |
((math-nearly-zerop-float x orgx) '(float 0 0)) |
((math-nearly-zerop-float x orgx) '(float 0 0)) |
847 |
(calc-symbolic-mode (signal 'inexact-result nil)) |
(calc-symbolic-mode (signal 'inexact-result nil)) |
848 |
(t (math-sin-series x 6 4 x (math-neg-float (math-sqr-float x)))))) |
(t (math-sin-series x 6 4 x (math-neg-float (math-sqr-float x))))))) |
|
) |
|
849 |
|
|
850 |
(defun math-cos-raw-2 (x orgx) ; [F F] |
(defun math-cos-raw-2 (x orgx) ; [F F] |
851 |
(cond ((math-nearly-zerop-float x orgx) '(float 1 0)) |
(cond ((math-nearly-zerop-float x orgx) '(float 1 0)) |
854 |
(math-sin-series |
(math-sin-series |
855 |
(math-add-float '(float 1 0) |
(math-add-float '(float 1 0) |
856 |
(math-mul-float xnegsqr '(float 5 -1))) |
(math-mul-float xnegsqr '(float 5 -1))) |
857 |
24 5 xnegsqr xnegsqr)))) |
24 5 xnegsqr xnegsqr))))) |
|
) |
|
858 |
|
|
859 |
(defun math-sin-series (sum nfac n x xnegsqr) |
(defun math-sin-series (sum nfac n x xnegsqr) |
860 |
(math-working "sin" sum) |
(math-working "sin" sum) |
864 |
(if (math-nearly-equal-float sum nextsum) |
(if (math-nearly-equal-float sum nextsum) |
865 |
sum |
sum |
866 |
(math-sin-series nextsum (math-mul nfac (* n (1+ n))) |
(math-sin-series nextsum (math-mul nfac (* n (1+ n))) |
867 |
(+ n 2) nextx xnegsqr))) |
(+ n 2) nextx xnegsqr)))) |
|
) |
|
868 |
|
|
869 |
|
|
870 |
;;; Inverse sine, cosine, tangent. |
;;; Inverse sine, cosine, tangent. |
890 |
((equal x '(var nan var-nan)) |
((equal x '(var nan var-nan)) |
891 |
x) |
x) |
892 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
893 |
(list 'calcFunc-arcsin x))) |
(list 'calcFunc-arcsin x)))) |
|
) |
|
894 |
|
|
895 |
(defun calcFunc-arccos (x) ; [N N] [Public] |
(defun calcFunc-arccos (x) ; [N N] [Public] |
896 |
(cond ((eq x 1) 0) |
(cond ((eq x 1) 0) |
913 |
((equal x '(var nan var-nan)) |
((equal x '(var nan var-nan)) |
914 |
x) |
x) |
915 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
916 |
(list 'calcFunc-arccos x))) |
(list 'calcFunc-arccos x)))) |
|
) |
|
917 |
|
|
918 |
(defun calcFunc-arctan (x) ; [N N] [Public] |
(defun calcFunc-arctan (x) ; [N N] [Public] |
919 |
(cond ((eq x 0) 0) |
(cond ((eq x 0) 0) |
938 |
((equal x '(var nan var-nan)) |
((equal x '(var nan var-nan)) |
939 |
x) |
x) |
940 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
941 |
(list 'calcFunc-arctan x))) |
(list 'calcFunc-arctan x)))) |
|
) |
|
942 |
|
|
943 |
(defun math-arcsin-raw (x) ; [N N] |
(defun math-arcsin-raw (x) ; [N N] |
944 |
(let ((a (math-sqrt-raw (math-sub '(float 1 0) (math-sqr x))))) |
(let ((a (math-sqrt-raw (math-sub '(float 1 0) (math-sqr x))))) |
947 |
(math-with-extra-prec 2 ; use extra precision for difficult case |
(math-with-extra-prec 2 ; use extra precision for difficult case |
948 |
(math-mul '(cplx 0 -1) |
(math-mul '(cplx 0 -1) |
949 |
(math-ln-raw (math-add (math-mul '(cplx 0 1) x) a)))) |
(math-ln-raw (math-add (math-mul '(cplx 0 1) x) a)))) |
950 |
(math-arctan2-raw x a))) |
(math-arctan2-raw x a)))) |
|
) |
|
951 |
|
|
952 |
(defun math-arccos-raw (x) ; [N N] |
(defun math-arccos-raw (x) ; [N N] |
953 |
(math-sub (math-pi-over-2) (math-arcsin-raw x)) |
(math-sub (math-pi-over-2) (math-arcsin-raw x))) |
|
) |
|
954 |
|
|
955 |
(defun math-arctan-raw (x) ; [N N] |
(defun math-arctan-raw (x) ; [N N] |
956 |
(cond ((memq (car x) '(cplx polar)) |
(cond ((memq (car x) '(cplx polar)) |
974 |
(math-sub-float '(float 1 0) x) |
(math-sub-float '(float 1 0) x) |
975 |
(math-add-float '(float 1 0) |
(math-add-float '(float 1 0) |
976 |
x)))))) |
x)))))) |
977 |
(t (math-arctan-series x 3 x (math-neg-float (math-sqr-float x))))) |
(t (math-arctan-series x 3 x (math-neg-float (math-sqr-float x)))))) |
|
) |
|
978 |
|
|
979 |
(defun math-arctan-series (sum n x xnegsqr) |
(defun math-arctan-series (sum n x xnegsqr) |
980 |
(math-working "arctan" sum) |
(math-working "arctan" sum) |
982 |
(nextsum (math-add-float sum (math-div-float nextx (math-float n))))) |
(nextsum (math-add-float sum (math-div-float nextx (math-float n))))) |
983 |
(if (math-nearly-equal-float sum nextsum) |
(if (math-nearly-equal-float sum nextsum) |
984 |
sum |
sum |
985 |
(math-arctan-series nextsum (+ n 2) nextx xnegsqr))) |
(math-arctan-series nextsum (+ n 2) nextx xnegsqr)))) |
|
) |
|
986 |
|
|
987 |
(defun calcFunc-arctan2 (y x) ; [F R R] [Public] |
(defun calcFunc-arctan2 (y x) ; [F R R] [Public] |
988 |
(if (Math-anglep y) |
(if (Math-anglep y) |
1011 |
(calcFunc-arctan2 y x) |
(calcFunc-arctan2 y x) |
1012 |
'(var nan var-nan))) |
'(var nan var-nan))) |
1013 |
(calc-record-why 'anglep y) |
(calc-record-why 'anglep y) |
1014 |
(list 'calcFunc-arctan2 y x))) |
(list 'calcFunc-arctan2 y x)))) |
|
) |
|
1015 |
|
|
1016 |
(defun math-arctan2-raw (y x) ; [F R R] |
(defun math-arctan2-raw (y x) ; [F R R] |
1017 |
(cond ((math-zerop y) |
(cond ((math-zerop y) |
1028 |
(math-pi))) |
(math-pi))) |
1029 |
(t |
(t |
1030 |
(math-sub-float (math-arctan-raw (math-div-float y x)) |
(math-sub-float (math-arctan-raw (math-div-float y x)) |
1031 |
(math-pi)))) |
(math-pi))))) |
|
) |
|
1032 |
|
|
1033 |
(defun calcFunc-arcsincos (x) ; [V N] [Public] |
(defun calcFunc-arcsincos (x) ; [V N] [Public] |
1034 |
(if (and (Math-vectorp x) |
(if (and (Math-vectorp x) |
1035 |
(= (length x) 3)) |
(= (length x) 3)) |
1036 |
(calcFunc-arctan2 (nth 2 x) (nth 1 x)) |
(calcFunc-arctan2 (nth 2 x) (nth 1 x)) |
1037 |
(math-reject-arg x "*Two-element vector expected")) |
(math-reject-arg x "*Two-element vector expected"))) |
|
) |
|
1038 |
|
|
1039 |
|
|
1040 |
|
|
1059 |
((equal x '(var nan var-nan)) |
((equal x '(var nan var-nan)) |
1060 |
x) |
x) |
1061 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
1062 |
(list 'calcFunc-exp x))) |
(list 'calcFunc-exp x)))) |
|
) |
|
1063 |
|
|
1064 |
(defun calcFunc-expm1 (x) ; [N N] [Public] |
(defun calcFunc-expm1 (x) ; [N N] [Public] |
1065 |
(cond ((eq x 0) 0) |
(cond ((eq x 0) 0) |
1090 |
((equal x '(var nan var-nan)) |
((equal x '(var nan var-nan)) |
1091 |
x) |
x) |
1092 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
1093 |
(list 'calcFunc-expm1 x))) |
(list 'calcFunc-expm1 x)))) |
|
) |
|
1094 |
|
|
1095 |
(defun calcFunc-exp10 (x) ; [N N] [Public] |
(defun calcFunc-exp10 (x) ; [N N] [Public] |
1096 |
(if (eq x 0) |
(if (eq x 0) |
1097 |
1 |
1 |
1098 |
(math-pow '(float 1 1) x)) |
(math-pow '(float 1 1) x))) |
|
) |
|
1099 |
|
|
1100 |
(defun math-exp-raw (x) ; [N N] |
(defun math-exp-raw (x) ; [N N] |
1101 |
(cond ((math-zerop x) '(float 1 0)) |
(cond ((math-zerop x) '(float 1 0)) |
1124 |
(math-mul-float (math-ipow (math-sqrt-e) hint) |
(math-mul-float (math-ipow (math-sqrt-e) hint) |
1125 |
(math-add-float '(float 1 0) |
(math-add-float '(float 1 0) |
1126 |
(math-exp-minus-1-raw hfrac))))) |
(math-exp-minus-1-raw hfrac))))) |
1127 |
(t (math-add-float '(float 1 0) (math-exp-minus-1-raw x)))) |
(t (math-add-float '(float 1 0) (math-exp-minus-1-raw x))))) |
|
) |
|
1128 |
|
|
1129 |
(defun math-exp-minus-1-raw (x) ; [F F] |
(defun math-exp-minus-1-raw (x) ; [F F] |
1130 |
(math-exp-series x 2 3 x x) |
(math-exp-series x 2 3 x x)) |
|
) |
|
1131 |
|
|
1132 |
(defun math-exp-series (sum nfac n xpow x) |
(defun math-exp-series (sum nfac n xpow x) |
1133 |
(math-working "exp" sum) |
(math-working "exp" sum) |
1136 |
(math-float nfac))))) |
(math-float nfac))))) |
1137 |
(if (math-nearly-equal-float sum nextsum) |
(if (math-nearly-equal-float sum nextsum) |
1138 |
sum |
sum |
1139 |
(math-exp-series nextsum (math-mul nfac n) (1+ n) nextx x))) |
(math-exp-series nextsum (math-mul nfac n) (1+ n) nextx x)))) |
|
) |
|
1140 |
|
|
1141 |
|
|
1142 |
|
|
1170 |
x |
x |
1171 |
'(var inf var-inf))) |
'(var inf var-inf))) |
1172 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
1173 |
(list 'calcFunc-ln x))) |
(list 'calcFunc-ln x)))) |
|
) |
|
1174 |
|
|
1175 |
(defun calcFunc-log10 (x) ; [N N] [Public] |
(defun calcFunc-log10 (x) ; [N N] [Public] |
1176 |
(cond ((math-equal-int x 1) |
(cond ((math-equal-int x 1) |
1221 |
x |
x |
1222 |
'(var inf var-inf))) |
'(var inf var-inf))) |
1223 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
1224 |
(list 'calcFunc-log10 x))) |
(list 'calcFunc-log10 x)))) |
|
) |
|
1225 |
|
|
1226 |
(defun calcFunc-log (x &optional b) ; [N N N] [Public] |
(defun calcFunc-log (x &optional b) ; [N N N] [Public] |
1227 |
(cond ((or (null b) (equal b '(var e var-e))) |
(cond ((or (null b) (equal b '(var e var-e))) |
1286 |
(t (if (Math-numberp b) |
(t (if (Math-numberp b) |
1287 |
(calc-record-why 'numberp x) |
(calc-record-why 'numberp x) |
1288 |
(calc-record-why 'numberp b)) |
(calc-record-why 'numberp b)) |
1289 |
(list 'calcFunc-log x b))) |
(list 'calcFunc-log x b)))) |
|
) |
|
1290 |
|
|
1291 |
(defun calcFunc-alog (x &optional b) |
(defun calcFunc-alog (x &optional b) |
1292 |
(cond ((or (null b) (equal b '(var e var-e))) |
(cond ((or (null b) (equal b '(var e var-e))) |
1293 |
(math-normalize (list 'calcFunc-exp x))) |
(math-normalize (list 'calcFunc-exp x))) |
1294 |
(t (math-pow b x))) |
(t (math-pow b x)))) |
|
) |
|
1295 |
|
|
1296 |
(defun calcFunc-ilog (x b) |
(defun calcFunc-ilog (x b) |
1297 |
(if (and (math-natnump x) (not (eq x 0)) |
(if (and (math-natnump x) (not (eq x 0)) |
1301 |
(if (Math-natnum-lessp x b) |
(if (Math-natnum-lessp x b) |
1302 |
0 |
0 |
1303 |
(cdr (math-integer-log x b)))) |
(cdr (math-integer-log x b)))) |
1304 |
(math-floor (calcFunc-log x b))) |
(math-floor (calcFunc-log x b)))) |
|
) |
|
1305 |
|
|
1306 |
(defun math-integer-log (x b) |
(defun math-integer-log (x b) |
1307 |
(let ((pows (list b)) |
(let ((pows (list b)) |
1321 |
(or (Math-lessp x next) |
(or (Math-lessp x next) |
1322 |
(setq pow next |
(setq pow next |
1323 |
sum (+ sum n)))) |
sum (+ sum n)))) |
1324 |
(cons (equal pow x) sum)) |
(cons (equal pow x) sum))) |
|
) |
|
1325 |
|
|
1326 |
|
|
1327 |
(defun math-log-base-raw (b) ; [N N] |
(defun math-log-base-raw (b) ; [N N] |
1329 |
(eq (nth 1 math-log-base-cache) calc-internal-prec))) |
(eq (nth 1 math-log-base-cache) calc-internal-prec))) |
1330 |
(setq math-log-base-cache (list b calc-internal-prec |
(setq math-log-base-cache (list b calc-internal-prec |
1331 |
(math-ln-raw (math-float b))))) |
(math-ln-raw (math-float b))))) |
1332 |
(nth 2 math-log-base-cache) |
(nth 2 math-log-base-cache)) |
|
) |
|
1333 |
(setq math-log-base-cache nil) |
(setq math-log-base-cache nil) |
1334 |
|
|
1335 |
(defun calcFunc-lnp1 (x) ; [N N] [Public] |
(defun calcFunc-lnp1 (x) ; [N N] [Public] |
1361 |
x |
x |
1362 |
'(var inf var-inf))) |
'(var inf var-inf))) |
1363 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
1364 |
(list 'calcFunc-lnp1 x))) |
(list 'calcFunc-lnp1 x)))) |
|
) |
|
1365 |
|
|
1366 |
(defun math-ln-raw (x) ; [N N] --- must be float format! |
(defun math-ln-raw (x) ; [N N] --- must be float format! |
1367 |
(cond ((eq (car-safe x) 'cplx) |
(cond ((eq (car-safe x) 'cplx) |
1392 |
(math-pi)))) |
(math-pi)))) |
1393 |
(t (list 'cplx ; negative and real |
(t (list 'cplx ; negative and real |
1394 |
(math-ln-raw (math-neg-float x)) |
(math-ln-raw (math-neg-float x)) |
1395 |
(math-pi)))) |
(math-pi))))) |
|
) |
|
1396 |
|
|
1397 |
(defun math-ln-raw-2 (x) ; [F F] |
(defun math-ln-raw-2 (x) ; [F F] |
1398 |
(cond ((math-lessp-float '(float 14 -1) x) |
(cond ((math-lessp-float '(float 14 -1) x) |
1400 |
(math-ln-2))) |
(math-ln-2))) |
1401 |
(t ; now .7 < x <= 1.4 |
(t ; now .7 < x <= 1.4 |
1402 |
(math-ln-raw-3 (math-div-float (math-sub-float x '(float 1 0)) |
(math-ln-raw-3 (math-div-float (math-sub-float x '(float 1 0)) |
1403 |
(math-add-float x '(float 1 0)))))) |
(math-add-float x '(float 1 0))))))) |
|
) |
|
1404 |
|
|
1405 |
(defun math-ln-raw-3 (x) ; [F F] |
(defun math-ln-raw-3 (x) ; [F F] |
1406 |
(math-mul-float (math-ln-raw-series x 3 x (math-sqr-float x)) |
(math-mul-float (math-ln-raw-series x 3 x (math-sqr-float x)) |
1407 |
'(float 2 0)) |
'(float 2 0))) |
|
) |
|
1408 |
|
|
1409 |
;;; Compute ln((1+x)/(1-x)) |
;;; Compute ln((1+x)/(1-x)) |
1410 |
(defun math-ln-raw-series (sum n x xsqr) |
(defun math-ln-raw-series (sum n x xsqr) |
1413 |
(nextsum (math-add-float sum (math-div-float nextx (math-float n))))) |
(nextsum (math-add-float sum (math-div-float nextx (math-float n))))) |
1414 |
(if (math-nearly-equal-float sum nextsum) |
(if (math-nearly-equal-float sum nextsum) |
1415 |
sum |
sum |
1416 |
(math-ln-raw-series nextsum (+ n 2) nextx xsqr))) |
(math-ln-raw-series nextsum (+ n 2) nextx xsqr)))) |
|
) |
|
1417 |
|
|
1418 |
(defun math-ln-plus-1-raw (x) |
(defun math-ln-plus-1-raw (x) |
1419 |
(math-lnp1-series x 2 x (math-neg x)) |
(math-lnp1-series x 2 x (math-neg x))) |
|
) |
|
1420 |
|
|
1421 |
(defun math-lnp1-series (sum n xpow x) |
(defun math-lnp1-series (sum n xpow x) |
1422 |
(math-working "lnp1" sum) |
(math-working "lnp1" sum) |
1424 |
(nextsum (math-add-float sum (math-div-float nextx (math-float n))))) |
(nextsum (math-add-float sum (math-div-float nextx (math-float n))))) |
1425 |
(if (math-nearly-equal-float sum nextsum) |
(if (math-nearly-equal-float sum nextsum) |
1426 |
sum |
sum |
1427 |
(math-lnp1-series nextsum (1+ n) nextx x))) |
(math-lnp1-series nextsum (1+ n) nextx x)))) |
|
) |
|
1428 |
|
|
1429 |
(math-defcache math-ln-10 (float (bigpos 018 684 045 994 092 585 302 2) -21) |
(math-defcache math-ln-10 (float (bigpos 018 684 045 994 092 585 302 2) -21) |
1430 |
(math-ln-raw-2 '(float 1 1))) |
(math-ln-raw-2 '(float 1 1))) |
1459 |
(equal x '(var nan var-nan))) |
(equal x '(var nan var-nan))) |
1460 |
x) |
x) |
1461 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
1462 |
(list 'calcFunc-sinh x))) |
(list 'calcFunc-sinh x)))) |
|
) |
|
1463 |
(put 'calcFunc-sinh 'math-expandable t) |
(put 'calcFunc-sinh 'math-expandable t) |
1464 |
|
|
1465 |
(defun calcFunc-cosh (x) ; [N N] [Public] |
(defun calcFunc-cosh (x) ; [N N] [Public] |
1487 |
(equal x '(var nan var-nan))) |
(equal x '(var nan var-nan))) |
1488 |
(math-abs x)) |
(math-abs x)) |
1489 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
1490 |
(list 'calcFunc-cosh x))) |
(list 'calcFunc-cosh x)))) |
|
) |
|
1491 |
(put 'calcFunc-cosh 'math-expandable t) |
(put 'calcFunc-cosh 'math-expandable t) |
1492 |
|
|
1493 |
(defun calcFunc-tanh (x) ; [N N] [Public] |
(defun calcFunc-tanh (x) ; [N N] [Public] |
1520 |
((equal x '(var nan var-nan)) |
((equal x '(var nan var-nan)) |
1521 |
x) |
x) |
1522 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
1523 |
(list 'calcFunc-tanh x))) |
(list 'calcFunc-tanh x)))) |
|
) |
|
1524 |
(put 'calcFunc-tanh 'math-expandable t) |
(put 'calcFunc-tanh 'math-expandable t) |
1525 |
|
|
1526 |
(defun calcFunc-arcsinh (x) ; [N N] [Public] |
(defun calcFunc-arcsinh (x) ; [N N] [Public] |
1548 |
(equal x '(var nan var-nan))) |
(equal x '(var nan var-nan))) |
1549 |
x) |
x) |
1550 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
1551 |
(list 'calcFunc-arcsinh x))) |
(list 'calcFunc-arcsinh x)))) |
|
) |
|
1552 |
(put 'calcFunc-arcsinh 'math-expandable t) |
(put 'calcFunc-arcsinh 'math-expandable t) |
1553 |
|
|
1554 |
(defun calcFunc-arccosh (x) ; [N N] [Public] |
(defun calcFunc-arccosh (x) ; [N N] [Public] |
1593 |
(equal x '(var nan var-nan))) |
(equal x '(var nan var-nan))) |
1594 |
x) |
x) |
1595 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
1596 |
(list 'calcFunc-arccosh x))) |
(list 'calcFunc-arccosh x)))) |
|
) |
|
1597 |
(put 'calcFunc-arccosh 'math-expandable t) |
(put 'calcFunc-arccosh 'math-expandable t) |
1598 |
|
|
1599 |
(defun calcFunc-arctanh (x) ; [N N] [Public] |
(defun calcFunc-arctanh (x) ; [N N] [Public] |
1632 |
((equal x '(var nan var-nan)) |
((equal x '(var nan var-nan)) |
1633 |
x) |
x) |
1634 |
(t (calc-record-why 'numberp x) |
(t (calc-record-why 'numberp x) |
1635 |
(list 'calcFunc-arctanh x))) |
(list 'calcFunc-arctanh x)))) |
|
) |
|
1636 |
(put 'calcFunc-arctanh 'math-expandable t) |
(put 'calcFunc-arctanh 'math-expandable t) |
1637 |
|
|
1638 |
|
|
1650 |
(math-expand-formulas |
(math-expand-formulas |
1651 |
(math-div (math-mul a '(var pi var-pi)) 180)) |
(math-div (math-mul a '(var pi var-pi)) 180)) |
1652 |
((math-infinitep a) a) |
((math-infinitep a) a) |
1653 |
(t (list 'calcFunc-rad a))) |
(t (list 'calcFunc-rad a)))) |
|
) |
|
1654 |
(put 'calcFunc-rad 'math-expandable t) |
(put 'calcFunc-rad 'math-expandable t) |
1655 |
|
|
1656 |
;;; Convert A from HMS or radians to degrees. |
;;; Convert A from HMS or radians to degrees. |
1667 |
(math-expand-formulas |
(math-expand-formulas |
1668 |
(math-div (math-mul 180 a) '(var pi var-pi))) |
(math-div (math-mul 180 a) '(var pi var-pi))) |
1669 |
((math-infinitep a) a) |
((math-infinitep a) a) |
1670 |
(t (list 'calcFunc-deg a))) |
(t (list 'calcFunc-deg a)))) |
|
) |
|
1671 |
(put 'calcFunc-deg 'math-expandable t) |
(put 'calcFunc-deg 'math-expandable t) |
1672 |
|
|
1673 |
|
;;; calc-math.el ends here |
1674 |
|
|
1675 |
|
|