diff options
| author | Colin Walters | 2001-11-14 09:05:36 +0000 |
|---|---|---|
| committer | Colin Walters | 2001-11-14 09:05:36 +0000 |
| commit | 491c306232fedcb792e55a1eecf59195852b36d9 (patch) | |
| tree | c6b9c4147f2919e86f82e82330a5d593a25e5bbb | |
| parent | cce7e5a603b28b4059de9f03abb2df722344c875 (diff) | |
| download | emacs-491c306232fedcb792e55a1eecf59195852b36d9.tar.gz emacs-491c306232fedcb792e55a1eecf59195852b36d9.zip | |
(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.
| -rw-r--r-- | lisp/calc/calc-math.el | 332 |
1 files changed, 112 insertions, 220 deletions
diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el index c7b841851e1..81a2503cfb5 100644 --- a/lisp/calc/calc-math.el +++ b/lisp/calc/calc-math.el | |||
| @@ -1,5 +1,5 @@ | |||
| 1 | ;; Calculator for GNU Emacs, part II [calc-math.el] | 1 | ;; Calculator for GNU Emacs, part II [calc-math.el] |
| 2 | ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. | 2 | ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
| 3 | ;; Written by Dave Gillespie, daveg@synaptics.com. | 3 | ;; Written by Dave Gillespie, daveg@synaptics.com. |
| 4 | 4 | ||
| 5 | ;; This file is part of GNU Emacs. | 5 | ;; This file is part of GNU Emacs. |
| @@ -34,57 +34,49 @@ | |||
| 34 | (calc-slow-wrapper | 34 | (calc-slow-wrapper |
| 35 | (if (calc-is-inverse) | 35 | (if (calc-is-inverse) |
| 36 | (calc-unary-op "^2" 'calcFunc-sqr arg) | 36 | (calc-unary-op "^2" 'calcFunc-sqr arg) |
| 37 | (calc-unary-op "sqrt" 'calcFunc-sqrt arg))) | 37 | (calc-unary-op "sqrt" 'calcFunc-sqrt arg)))) |
| 38 | ) | ||
| 39 | 38 | ||
| 40 | (defun calc-isqrt (arg) | 39 | (defun calc-isqrt (arg) |
| 41 | (interactive "P") | 40 | (interactive "P") |
| 42 | (calc-slow-wrapper | 41 | (calc-slow-wrapper |
| 43 | (if (calc-is-inverse) | 42 | (if (calc-is-inverse) |
| 44 | (calc-unary-op "^2" 'calcFunc-sqr arg) | 43 | (calc-unary-op "^2" 'calcFunc-sqr arg) |
| 45 | (calc-unary-op "isqt" 'calcFunc-isqrt arg))) | 44 | (calc-unary-op "isqt" 'calcFunc-isqrt arg)))) |
| 46 | ) | ||
| 47 | 45 | ||
| 48 | 46 | ||
| 49 | (defun calc-hypot (arg) | 47 | (defun calc-hypot (arg) |
| 50 | (interactive "P") | 48 | (interactive "P") |
| 51 | (calc-slow-wrapper | 49 | (calc-slow-wrapper |
| 52 | (calc-binary-op "hypt" 'calcFunc-hypot arg)) | 50 | (calc-binary-op "hypt" 'calcFunc-hypot arg))) |
| 53 | ) | ||
| 54 | 51 | ||
| 55 | (defun calc-ln (arg) | 52 | (defun calc-ln (arg) |
| 56 | (interactive "P") | 53 | (interactive "P") |
| 57 | (calc-invert-func) | 54 | (calc-invert-func) |
| 58 | (calc-exp arg) | 55 | (calc-exp arg)) |
| 59 | ) | ||
| 60 | 56 | ||
| 61 | (defun calc-log10 (arg) | 57 | (defun calc-log10 (arg) |
| 62 | (interactive "P") | 58 | (interactive "P") |
| 63 | (calc-hyperbolic-func) | 59 | (calc-hyperbolic-func) |
| 64 | (calc-ln arg) | 60 | (calc-ln arg)) |
| 65 | ) | ||
| 66 | 61 | ||
| 67 | (defun calc-log (arg) | 62 | (defun calc-log (arg) |
| 68 | (interactive "P") | 63 | (interactive "P") |
| 69 | (calc-slow-wrapper | 64 | (calc-slow-wrapper |
| 70 | (if (calc-is-inverse) | 65 | (if (calc-is-inverse) |
| 71 | (calc-binary-op "alog" 'calcFunc-alog arg) | 66 | (calc-binary-op "alog" 'calcFunc-alog arg) |
| 72 | (calc-binary-op "log" 'calcFunc-log arg))) | 67 | (calc-binary-op "log" 'calcFunc-log arg)))) |
| 73 | ) | ||
| 74 | 68 | ||
| 75 | (defun calc-ilog (arg) | 69 | (defun calc-ilog (arg) |
| 76 | (interactive "P") | 70 | (interactive "P") |
| 77 | (calc-slow-wrapper | 71 | (calc-slow-wrapper |
| 78 | (if (calc-is-inverse) | 72 | (if (calc-is-inverse) |
| 79 | (calc-binary-op "alog" 'calcFunc-alog arg) | 73 | (calc-binary-op "alog" 'calcFunc-alog arg) |
| 80 | (calc-binary-op "ilog" 'calcFunc-ilog arg))) | 74 | (calc-binary-op "ilog" 'calcFunc-ilog arg)))) |
| 81 | ) | ||
| 82 | 75 | ||
| 83 | (defun calc-lnp1 (arg) | 76 | (defun calc-lnp1 (arg) |
| 84 | (interactive "P") | 77 | (interactive "P") |
| 85 | (calc-invert-func) | 78 | (calc-invert-func) |
| 86 | (calc-expm1 arg) | 79 | (calc-expm1 arg)) |
| 87 | ) | ||
| 88 | 80 | ||
| 89 | (defun calc-exp (arg) | 81 | (defun calc-exp (arg) |
| 90 | (interactive "P") | 82 | (interactive "P") |
| @@ -95,16 +87,14 @@ | |||
| 95 | (calc-unary-op "10^" 'calcFunc-exp10 arg)) | 87 | (calc-unary-op "10^" 'calcFunc-exp10 arg)) |
| 96 | (if (calc-is-inverse) | 88 | (if (calc-is-inverse) |
| 97 | (calc-unary-op "ln" 'calcFunc-ln arg) | 89 | (calc-unary-op "ln" 'calcFunc-ln arg) |
| 98 | (calc-unary-op "exp" 'calcFunc-exp arg)))) | 90 | (calc-unary-op "exp" 'calcFunc-exp arg))))) |
| 99 | ) | ||
| 100 | 91 | ||
| 101 | (defun calc-expm1 (arg) | 92 | (defun calc-expm1 (arg) |
| 102 | (interactive "P") | 93 | (interactive "P") |
| 103 | (calc-slow-wrapper | 94 | (calc-slow-wrapper |
| 104 | (if (calc-is-inverse) | 95 | (if (calc-is-inverse) |
| 105 | (calc-unary-op "ln+1" 'calcFunc-lnp1 arg) | 96 | (calc-unary-op "ln+1" 'calcFunc-lnp1 arg) |
| 106 | (calc-unary-op "ex-1" 'calcFunc-expm1 arg))) | 97 | (calc-unary-op "ex-1" 'calcFunc-expm1 arg)))) |
| 107 | ) | ||
| 108 | 98 | ||
| 109 | (defun calc-pi () | 99 | (defun calc-pi () |
| 110 | (interactive) | 100 | (interactive) |
| @@ -123,8 +113,7 @@ | |||
| 123 | (calc-pop-push-record 0 "e" (math-e))) | 113 | (calc-pop-push-record 0 "e" (math-e))) |
| 124 | (if calc-symbolic-mode | 114 | (if calc-symbolic-mode |
| 125 | (calc-pop-push-record 0 "pi" '(var pi var-pi)) | 115 | (calc-pop-push-record 0 "pi" '(var pi var-pi)) |
| 126 | (calc-pop-push-record 0 "pi" (math-pi)))))) | 116 | (calc-pop-push-record 0 "pi" (math-pi))))))) |
| 127 | ) | ||
| 128 | 117 | ||
| 129 | (defun calc-sin (arg) | 118 | (defun calc-sin (arg) |
| 130 | (interactive "P") | 119 | (interactive "P") |
| @@ -135,27 +124,23 @@ | |||
| 135 | (calc-unary-op "sinh" 'calcFunc-sinh arg)) | 124 | (calc-unary-op "sinh" 'calcFunc-sinh arg)) |
| 136 | (if (calc-is-inverse) | 125 | (if (calc-is-inverse) |
| 137 | (calc-unary-op "asin" 'calcFunc-arcsin arg) | 126 | (calc-unary-op "asin" 'calcFunc-arcsin arg) |
| 138 | (calc-unary-op "sin" 'calcFunc-sin arg)))) | 127 | (calc-unary-op "sin" 'calcFunc-sin arg))))) |
| 139 | ) | ||
| 140 | 128 | ||
| 141 | (defun calc-arcsin (arg) | 129 | (defun calc-arcsin (arg) |
| 142 | (interactive "P") | 130 | (interactive "P") |
| 143 | (calc-invert-func) | 131 | (calc-invert-func) |
| 144 | (calc-sin arg) | 132 | (calc-sin arg)) |
| 145 | ) | ||
| 146 | 133 | ||
| 147 | (defun calc-sinh (arg) | 134 | (defun calc-sinh (arg) |
| 148 | (interactive "P") | 135 | (interactive "P") |
| 149 | (calc-hyperbolic-func) | 136 | (calc-hyperbolic-func) |
| 150 | (calc-sin arg) | 137 | (calc-sin arg)) |
| 151 | ) | ||
| 152 | 138 | ||
| 153 | (defun calc-arcsinh (arg) | 139 | (defun calc-arcsinh (arg) |
| 154 | (interactive "P") | 140 | (interactive "P") |
| 155 | (calc-invert-func) | 141 | (calc-invert-func) |
| 156 | (calc-hyperbolic-func) | 142 | (calc-hyperbolic-func) |
| 157 | (calc-sin arg) | 143 | (calc-sin arg)) |
| 158 | ) | ||
| 159 | 144 | ||
| 160 | (defun calc-cos (arg) | 145 | (defun calc-cos (arg) |
| 161 | (interactive "P") | 146 | (interactive "P") |
| @@ -166,35 +151,30 @@ | |||
| 166 | (calc-unary-op "cosh" 'calcFunc-cosh arg)) | 151 | (calc-unary-op "cosh" 'calcFunc-cosh arg)) |
| 167 | (if (calc-is-inverse) | 152 | (if (calc-is-inverse) |
| 168 | (calc-unary-op "acos" 'calcFunc-arccos arg) | 153 | (calc-unary-op "acos" 'calcFunc-arccos arg) |
| 169 | (calc-unary-op "cos" 'calcFunc-cos arg)))) | 154 | (calc-unary-op "cos" 'calcFunc-cos arg))))) |
| 170 | ) | ||
| 171 | 155 | ||
| 172 | (defun calc-arccos (arg) | 156 | (defun calc-arccos (arg) |
| 173 | (interactive "P") | 157 | (interactive "P") |
| 174 | (calc-invert-func) | 158 | (calc-invert-func) |
| 175 | (calc-cos arg) | 159 | (calc-cos arg)) |
| 176 | ) | ||
| 177 | 160 | ||
| 178 | (defun calc-cosh (arg) | 161 | (defun calc-cosh (arg) |
| 179 | (interactive "P") | 162 | (interactive "P") |
| 180 | (calc-hyperbolic-func) | 163 | (calc-hyperbolic-func) |
| 181 | (calc-cos arg) | 164 | (calc-cos arg)) |
| 182 | ) | ||
| 183 | 165 | ||
| 184 | (defun calc-arccosh (arg) | 166 | (defun calc-arccosh (arg) |
| 185 | (interactive "P") | 167 | (interactive "P") |
| 186 | (calc-invert-func) | 168 | (calc-invert-func) |
| 187 | (calc-hyperbolic-func) | 169 | (calc-hyperbolic-func) |
| 188 | (calc-cos arg) | 170 | (calc-cos arg)) |
| 189 | ) | ||
| 190 | 171 | ||
| 191 | (defun calc-sincos () | 172 | (defun calc-sincos () |
| 192 | (interactive) | 173 | (interactive) |
| 193 | (calc-slow-wrapper | 174 | (calc-slow-wrapper |
| 194 | (if (calc-is-inverse) | 175 | (if (calc-is-inverse) |
| 195 | (calc-enter-result 1 "asnc" (list 'calcFunc-arcsincos (calc-top-n 1))) | 176 | (calc-enter-result 1 "asnc" (list 'calcFunc-arcsincos (calc-top-n 1))) |
| 196 | (calc-enter-result 1 "sncs" (list 'calcFunc-sincos (calc-top-n 1))))) | 177 | (calc-enter-result 1 "sncs" (list 'calcFunc-sincos (calc-top-n 1)))))) |
| 197 | ) | ||
| 198 | 178 | ||
| 199 | (defun calc-tan (arg) | 179 | (defun calc-tan (arg) |
| 200 | (interactive "P") | 180 | (interactive "P") |
| @@ -205,59 +185,50 @@ | |||
| 205 | (calc-unary-op "tanh" 'calcFunc-tanh arg)) | 185 | (calc-unary-op "tanh" 'calcFunc-tanh arg)) |
| 206 | (if (calc-is-inverse) | 186 | (if (calc-is-inverse) |
| 207 | (calc-unary-op "atan" 'calcFunc-arctan arg) | 187 | (calc-unary-op "atan" 'calcFunc-arctan arg) |
| 208 | (calc-unary-op "tan" 'calcFunc-tan arg)))) | 188 | (calc-unary-op "tan" 'calcFunc-tan arg))))) |
| 209 | ) | ||
| 210 | 189 | ||
| 211 | (defun calc-arctan (arg) | 190 | (defun calc-arctan (arg) |
| 212 | (interactive "P") | 191 | (interactive "P") |
| 213 | (calc-invert-func) | 192 | (calc-invert-func) |
| 214 | (calc-tan arg) | 193 | (calc-tan arg)) |
| 215 | ) | ||
| 216 | 194 | ||
| 217 | (defun calc-tanh (arg) | 195 | (defun calc-tanh (arg) |
| 218 | (interactive "P") | 196 | (interactive "P") |
| 219 | (calc-hyperbolic-func) | 197 | (calc-hyperbolic-func) |
| 220 | (calc-tan arg) | 198 | (calc-tan arg)) |
| 221 | ) | ||
| 222 | 199 | ||
| 223 | (defun calc-arctanh (arg) | 200 | (defun calc-arctanh (arg) |
| 224 | (interactive "P") | 201 | (interactive "P") |
| 225 | (calc-invert-func) | 202 | (calc-invert-func) |
| 226 | (calc-hyperbolic-func) | 203 | (calc-hyperbolic-func) |
| 227 | (calc-tan arg) | 204 | (calc-tan arg)) |
| 228 | ) | ||
| 229 | 205 | ||
| 230 | (defun calc-arctan2 () | 206 | (defun calc-arctan2 () |
| 231 | (interactive) | 207 | (interactive) |
| 232 | (calc-slow-wrapper | 208 | (calc-slow-wrapper |
| 233 | (calc-enter-result 2 "atn2" (cons 'calcFunc-arctan2 (calc-top-list-n 2)))) | 209 | (calc-enter-result 2 "atn2" (cons 'calcFunc-arctan2 (calc-top-list-n 2))))) |
| 234 | ) | ||
| 235 | 210 | ||
| 236 | (defun calc-conj (arg) | 211 | (defun calc-conj (arg) |
| 237 | (interactive "P") | 212 | (interactive "P") |
| 238 | (calc-wrapper | 213 | (calc-wrapper |
| 239 | (calc-unary-op "conj" 'calcFunc-conj arg)) | 214 | (calc-unary-op "conj" 'calcFunc-conj arg))) |
| 240 | ) | ||
| 241 | 215 | ||
| 242 | (defun calc-imaginary () | 216 | (defun calc-imaginary () |
| 243 | (interactive) | 217 | (interactive) |
| 244 | (calc-slow-wrapper | 218 | (calc-slow-wrapper |
| 245 | (calc-pop-push-record 1 "i*" (math-imaginary (calc-top-n 1)))) | 219 | (calc-pop-push-record 1 "i*" (math-imaginary (calc-top-n 1))))) |
| 246 | ) | ||
| 247 | 220 | ||
| 248 | 221 | ||
| 249 | 222 | ||
| 250 | (defun calc-to-degrees (arg) | 223 | (defun calc-to-degrees (arg) |
| 251 | (interactive "P") | 224 | (interactive "P") |
| 252 | (calc-wrapper | 225 | (calc-wrapper |
| 253 | (calc-unary-op ">deg" 'calcFunc-deg arg)) | 226 | (calc-unary-op ">deg" 'calcFunc-deg arg))) |
| 254 | ) | ||
| 255 | 227 | ||
| 256 | (defun calc-to-radians (arg) | 228 | (defun calc-to-radians (arg) |
| 257 | (interactive "P") | 229 | (interactive "P") |
| 258 | (calc-wrapper | 230 | (calc-wrapper |
| 259 | (calc-unary-op ">rad" 'calcFunc-rad arg)) | 231 | (calc-unary-op ">rad" 'calcFunc-rad arg))) |
| 260 | ) | ||
| 261 | 232 | ||
| 262 | 233 | ||
| 263 | (defun calc-degrees-mode (arg) | 234 | (defun calc-degrees-mode (arg) |
| @@ -268,15 +239,13 @@ | |||
| 268 | (message "Angles measured in degrees."))) | 239 | (message "Angles measured in degrees."))) |
| 269 | ((= arg 2) (calc-radians-mode)) | 240 | ((= arg 2) (calc-radians-mode)) |
| 270 | ((= arg 3) (calc-hms-mode)) | 241 | ((= arg 3) (calc-hms-mode)) |
| 271 | (t (error "Prefix argument out of range"))) | 242 | (t (error "Prefix argument out of range")))) |
| 272 | ) | ||
| 273 | 243 | ||
| 274 | (defun calc-radians-mode () | 244 | (defun calc-radians-mode () |
| 275 | (interactive) | 245 | (interactive) |
| 276 | (calc-wrapper | 246 | (calc-wrapper |
| 277 | (calc-change-mode 'calc-angle-mode 'rad) | 247 | (calc-change-mode 'calc-angle-mode 'rad) |
| 278 | (message "Angles measured in radians.")) | 248 | (message "Angles measured in radians."))) |
| 279 | ) | ||
| 280 | 249 | ||
| 281 | 250 | ||
| 282 | ;;; Compute the integer square-root floor(sqrt(A)). A > 0. [I I] [Public] | 251 | ;;; Compute the integer square-root floor(sqrt(A)). A > 0. [I I] [Public] |
| @@ -289,14 +258,12 @@ | |||
| 289 | ((integerp a) | 258 | ((integerp a) |
| 290 | (math-isqrt-small a)) | 259 | (math-isqrt-small a)) |
| 291 | (t | 260 | (t |
| 292 | (math-normalize (cons 'bigpos (cdr (math-isqrt-bignum (cdr a))))))) | 261 | (math-normalize (cons 'bigpos (cdr (math-isqrt-bignum (cdr a)))))))) |
| 293 | ) | ||
| 294 | 262 | ||
| 295 | (defun calcFunc-isqrt (a) | 263 | (defun calcFunc-isqrt (a) |
| 296 | (if (math-realp a) | 264 | (if (math-realp a) |
| 297 | (math-isqrt (math-floor a)) | 265 | (math-isqrt (math-floor a)) |
| 298 | (math-floor (math-sqrt a))) | 266 | (math-floor (math-sqrt a)))) |
| 299 | ) | ||
| 300 | 267 | ||
| 301 | 268 | ||
| 302 | ;;; This returns (flag . result) where the flag is T if A is a perfect square. | 269 | ;;; This returns (flag . result) where the flag is T if A is a perfect square. |
| @@ -316,8 +283,7 @@ | |||
| 316 | a | 283 | a |
| 317 | (math-scale-bignum-3 | 284 | (math-scale-bignum-3 |
| 318 | (list (1+ (math-isqrt-small top))) | 285 | (list (1+ (math-isqrt-small top))) |
| 319 | (/ len 2)))))) | 286 | (/ len 2))))))) |
| 320 | ) | ||
| 321 | 287 | ||
| 322 | (defun math-isqrt-bignum-iter (a guess) ; [l L l] | 288 | (defun math-isqrt-bignum-iter (a guess) ; [l L l] |
| 323 | (math-working "isqrt" (cons 'bigpos guess)) | 289 | (math-working "isqrt" (cons 'bigpos guess)) |
| @@ -330,22 +296,19 @@ | |||
| 330 | (cons (and (= comp 0) | 296 | (cons (and (= comp 0) |
| 331 | (math-zerop-bignum (cdr q)) | 297 | (math-zerop-bignum (cdr q)) |
| 332 | (= (% (car s) 2) 0)) | 298 | (= (% (car s) 2) 0)) |
| 333 | guess))) | 299 | guess)))) |
| 334 | ) | ||
| 335 | 300 | ||
| 336 | (defun math-zerop-bignum (a) | 301 | (defun math-zerop-bignum (a) |
| 337 | (and (eq (car a) 0) | 302 | (and (eq (car a) 0) |
| 338 | (progn | 303 | (progn |
| 339 | (while (eq (car (setq a (cdr a))) 0)) | 304 | (while (eq (car (setq a (cdr a))) 0)) |
| 340 | (null a))) | 305 | (null a)))) |
| 341 | ) | ||
| 342 | 306 | ||
| 343 | (defun math-scale-bignum-3 (a n) ; [L L S] | 307 | (defun math-scale-bignum-3 (a n) ; [L L S] |
| 344 | (while (> n 0) | 308 | (while (> n 0) |
| 345 | (setq a (cons 0 a) | 309 | (setq a (cons 0 a) |
| 346 | n (1- n))) | 310 | n (1- n))) |
| 347 | a | 311 | a) |
| 348 | ) | ||
| 349 | 312 | ||
| 350 | (defun math-isqrt-small (a) ; A > 0. [S S] | 313 | (defun math-isqrt-small (a) ; A > 0. [S S] |
| 351 | (let ((g (cond ((>= a 10000) 1000) | 314 | (let ((g (cond ((>= a 10000) 1000) |
| @@ -354,8 +317,7 @@ | |||
| 354 | g2) | 317 | g2) |
| 355 | (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) | 318 | (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) |
| 356 | (setq g g2)) | 319 | (setq g g2)) |
| 357 | g) | 320 | g)) |
| 358 | ) | ||
| 359 | 321 | ||
| 360 | 322 | ||
| 361 | 323 | ||
| @@ -449,20 +411,17 @@ | |||
| 449 | (math-mul (math-sqrt (math-infinite-dir a inf)) inf))) | 411 | (math-mul (math-sqrt (math-infinite-dir a inf)) inf))) |
| 450 | (progn | 412 | (progn |
| 451 | (calc-record-why 'numberp a) | 413 | (calc-record-why 'numberp a) |
| 452 | (list 'calcFunc-sqrt a))) | 414 | (list 'calcFunc-sqrt a)))) |
| 453 | ) | 415 | (defalias calcFunc-sqrt 'math-sqrt) |
| 454 | (fset 'calcFunc-sqrt (symbol-function 'math-sqrt)) | ||
| 455 | 416 | ||
| 456 | (defun math-infinite-dir (a &optional inf) | 417 | (defun math-infinite-dir (a &optional inf) |
| 457 | (or inf (setq inf (math-infinitep a))) | 418 | (or inf (setq inf (math-infinitep a))) |
| 458 | (math-normalize (math-expr-subst a inf 1)) | 419 | (math-normalize (math-expr-subst a inf 1))) |
| 459 | ) | ||
| 460 | 420 | ||
| 461 | (defun math-sqrt-float (a &optional guess) ; [F F F] | 421 | (defun math-sqrt-float (a &optional guess) ; [F F F] |
| 462 | (if calc-symbolic-mode | 422 | (if calc-symbolic-mode |
| 463 | (signal 'inexact-result nil) | 423 | (signal 'inexact-result nil) |
| 464 | (math-with-extra-prec 1 (math-sqrt-raw a guess))) | 424 | (math-with-extra-prec 1 (math-sqrt-raw a guess)))) |
| 465 | ) | ||
| 466 | 425 | ||
| 467 | (defun math-sqrt-raw (a &optional guess) ; [F F F] | 426 | (defun math-sqrt-raw (a &optional guess) ; [F F F] |
| 468 | (if (not (Math-posp a)) | 427 | (if (not (Math-posp a)) |
| @@ -473,8 +432,7 @@ | |||
| 473 | (setq guess (math-make-float (math-isqrt-small | 432 | (setq guess (math-make-float (math-isqrt-small |
| 474 | (math-scale-int (nth 1 a) (- ldiff))) | 433 | (math-scale-int (nth 1 a) (- ldiff))) |
| 475 | (/ (+ (nth 2 a) ldiff) 2))))) | 434 | (/ (+ (nth 2 a) ldiff) 2))))) |
| 476 | (math-sqrt-float-iter a guess)) | 435 | (math-sqrt-float-iter a guess))) |
| 477 | ) | ||
| 478 | 436 | ||
| 479 | (defun math-sqrt-float-iter (a guess) ; [F F F] | 437 | (defun math-sqrt-float-iter (a guess) ; [F F F] |
| 480 | (math-working "sqrt" guess) | 438 | (math-working "sqrt" guess) |
| @@ -482,8 +440,7 @@ | |||
| 482 | '(float 5 -1)))) | 440 | '(float 5 -1)))) |
| 483 | (if (math-nearly-equal-float g2 guess) | 441 | (if (math-nearly-equal-float g2 guess) |
| 484 | g2 | 442 | g2 |
| 485 | (math-sqrt-float-iter a g2))) | 443 | (math-sqrt-float-iter a g2)))) |
| 486 | ) | ||
| 487 | 444 | ||
| 488 | ;;; True if A and B differ only in the last digit of precision. [P F F] | 445 | ;;; True if A and B differ only in the last digit of precision. [P F F] |
| 489 | (defun math-nearly-equal-float (a b) | 446 | (defun math-nearly-equal-float (a b) |
| @@ -508,8 +465,7 @@ | |||
| 508 | (and (not (consp ediff)) | 465 | (and (not (consp ediff)) |
| 509 | (< ediff 10) | 466 | (< ediff 10) |
| 510 | (> ediff -10) | 467 | (> ediff -10) |
| 511 | (= (math-numdigs (nth 1 a)) calc-internal-prec))))) | 468 | (= (math-numdigs (nth 1 a)) calc-internal-prec)))))) |
| 512 | ) | ||
| 513 | 469 | ||
| 514 | (defun math-nearly-equal (a b) ; [P N N] [Public] | 470 | (defun math-nearly-equal (a b) ; [P N N] [Public] |
| 515 | (setq a (math-float a)) | 471 | (setq a (math-float a)) |
| @@ -529,15 +485,13 @@ | |||
| 529 | (if (eq (car b) 'cplx) | 485 | (if (eq (car b) 'cplx) |
| 530 | (and (math-nearly-equal-float a (nth 1 b)) | 486 | (and (math-nearly-equal-float a (nth 1 b)) |
| 531 | (math-nearly-zerop-float a (nth 2 b))) | 487 | (math-nearly-zerop-float a (nth 2 b))) |
| 532 | (math-nearly-equal-float a b))) | 488 | (math-nearly-equal-float a b)))) |
| 533 | ) | ||
| 534 | 489 | ||
| 535 | ;;; True if A is nearly zero compared to B. [P F F] | 490 | ;;; True if A is nearly zero compared to B. [P F F] |
| 536 | (defun math-nearly-zerop-float (a b) | 491 | (defun math-nearly-zerop-float (a b) |
| 537 | (or (eq (nth 1 a) 0) | 492 | (or (eq (nth 1 a) 0) |
| 538 | (<= (+ (math-numdigs (nth 1 a)) (nth 2 a)) | 493 | (<= (+ (math-numdigs (nth 1 a)) (nth 2 a)) |
| 539 | (1+ (- (+ (math-numdigs (nth 1 b)) (nth 2 b)) calc-internal-prec)))) | 494 | (1+ (- (+ (math-numdigs (nth 1 b)) (nth 2 b)) calc-internal-prec))))) |
| 540 | ) | ||
| 541 | 495 | ||
| 542 | (defun math-nearly-zerop (a b) ; [P N R] [Public] | 496 | (defun math-nearly-zerop (a b) ; [P N R] [Public] |
| 543 | (setq a (math-float a)) | 497 | (setq a (math-float a)) |
| @@ -547,8 +501,7 @@ | |||
| 547 | (math-nearly-zerop-float (nth 2 a) b)) | 501 | (math-nearly-zerop-float (nth 2 a) b)) |
| 548 | (if (eq (car a) 'polar) | 502 | (if (eq (car a) 'polar) |
| 549 | (math-nearly-zerop-float (nth 1 a) b) | 503 | (math-nearly-zerop-float (nth 1 a) b) |
| 550 | (math-nearly-zerop-float a b))) | 504 | (math-nearly-zerop-float a b)))) |
| 551 | ) | ||
| 552 | 505 | ||
| 553 | ;;; This implementation could be improved, accuracy-wise. | 506 | ;;; This implementation could be improved, accuracy-wise. |
| 554 | (defun math-hypot (a b) | 507 | (defun math-hypot (a b) |
| @@ -578,13 +531,11 @@ | |||
| 578 | (math-to-hms (math-hypot (math-from-hms a 'deg) b)))) | 531 | (math-to-hms (math-hypot (math-from-hms a 'deg) b)))) |
| 579 | ((eq (car-safe b) 'hms) | 532 | ((eq (car-safe b) 'hms) |
| 580 | (math-to-hms (math-hypot a (math-from-hms b 'deg)))) | 533 | (math-to-hms (math-hypot a (math-from-hms b 'deg)))) |
| 581 | (t nil)) | 534 | (t nil))) |
| 582 | ) | 535 | (defalias calcFunc-hypot 'math-hypot) |
| 583 | (fset 'calcFunc-hypot (symbol-function 'math-hypot)) | ||
| 584 | 536 | ||
| 585 | (defun calcFunc-sqr (x) | 537 | (defun calcFunc-sqr (x) |
| 586 | (math-pow x 2) | 538 | (math-pow x 2)) |
| 587 | ) | ||
| 588 | 539 | ||
| 589 | 540 | ||
| 590 | 541 | ||
| @@ -615,8 +566,7 @@ | |||
| 615 | ((eq (car-safe a) 'polar) | 566 | ((eq (car-safe a) 'polar) |
| 616 | (let ((root (math-nth-root (nth 1 a) n))) | 567 | (let ((root (math-nth-root (nth 1 a) n))) |
| 617 | (and root (list 'polar root (math-div (nth 2 a) n))))) | 568 | (and root (list 'polar root (math-div (nth 2 a) n))))) |
| 618 | (t nil)) | 569 | (t nil))) |
| 619 | ) | ||
| 620 | 570 | ||
| 621 | (defun math-nth-root-float (a n &optional guess) | 571 | (defun math-nth-root-float (a n &optional guess) |
| 622 | (math-inexact-result) | 572 | (math-inexact-result) |
| @@ -628,8 +578,7 @@ | |||
| 628 | 1 (/ (+ (math-numdigs (nth 1 a)) | 578 | 1 (/ (+ (math-numdigs (nth 1 a)) |
| 629 | (nth 2 a) | 579 | (nth 2 a) |
| 630 | (/ n 2)) | 580 | (/ n 2)) |
| 631 | n)))))) | 581 | n))))))) |
| 632 | ) | ||
| 633 | 582 | ||
| 634 | (defun math-nth-root-float-iter (a guess) ; uses "n", "nf", "nfm1" | 583 | (defun math-nth-root-float-iter (a guess) ; uses "n", "nf", "nfm1" |
| 635 | (math-working "root" guess) | 584 | (math-working "root" guess) |
| @@ -639,15 +588,13 @@ | |||
| 639 | nf))) | 588 | nf))) |
| 640 | (if (math-nearly-equal-float g2 guess) | 589 | (if (math-nearly-equal-float g2 guess) |
| 641 | g2 | 590 | g2 |
| 642 | (math-nth-root-float-iter a g2))) | 591 | (math-nth-root-float-iter a g2)))) |
| 643 | ) | ||
| 644 | 592 | ||
| 645 | (defun math-nth-root-integer (a n &optional guess) ; [I I S] | 593 | (defun math-nth-root-integer (a n &optional guess) ; [I I S] |
| 646 | (math-nth-root-int-iter a (or guess | 594 | (math-nth-root-int-iter a (or guess |
| 647 | (math-scale-int 1 (/ (+ (math-numdigs a) | 595 | (math-scale-int 1 (/ (+ (math-numdigs a) |
| 648 | (1- n)) | 596 | (1- n)) |
| 649 | n)))) | 597 | n))))) |
| 650 | ) | ||
| 651 | 598 | ||
| 652 | (defun math-nth-root-int-iter (a guess) ; uses "n" | 599 | (defun math-nth-root-int-iter (a guess) ; uses "n" |
| 653 | (math-working "root" guess) | 600 | (math-working "root" guess) |
| @@ -659,14 +606,12 @@ | |||
| 659 | (cons (and (equal (car g2) guess) | 606 | (cons (and (equal (car g2) guess) |
| 660 | (eq (cdr q) 0) | 607 | (eq (cdr q) 0) |
| 661 | (eq (cdr g2) 0)) | 608 | (eq (cdr g2) 0)) |
| 662 | guess))) | 609 | guess)))) |
| 663 | ) | ||
| 664 | 610 | ||
| 665 | (defun calcFunc-nroot (x n) | 611 | (defun calcFunc-nroot (x n) |
| 666 | (calcFunc-pow x (if (integerp n) | 612 | (calcFunc-pow x (if (integerp n) |
| 667 | (math-make-frac 1 n) | 613 | (math-make-frac 1 n) |
| 668 | (math-div 1 n))) | 614 | (math-div 1 n)))) |
| 669 | ) | ||
| 670 | 615 | ||
| 671 | 616 | ||
| 672 | 617 | ||
| @@ -686,8 +631,7 @@ | |||
| 686 | (math-from-hms a 'rad)) | 631 | (math-from-hms a 'rad)) |
| 687 | ((memq calc-angle-mode '(deg hms)) | 632 | ((memq calc-angle-mode '(deg hms)) |
| 688 | (math-mul a (math-pi-over-180))) | 633 | (math-mul a (math-pi-over-180))) |
| 689 | (t a)) | 634 | (t a))) |
| 690 | ) | ||
| 691 | 635 | ||
| 692 | (defun math-from-radians (a) ; [N N] | 636 | (defun math-from-radians (a) ; [N N] |
| 693 | (cond ((eq calc-angle-mode 'deg) | 637 | (cond ((eq calc-angle-mode 'deg) |
| @@ -696,8 +640,7 @@ | |||
| 696 | (list 'calcFunc-deg a))) | 640 | (list 'calcFunc-deg a))) |
| 697 | ((eq calc-angle-mode 'hms) | 641 | ((eq calc-angle-mode 'hms) |
| 698 | (math-to-hms a 'rad)) | 642 | (math-to-hms a 'rad)) |
| 699 | (t a)) | 643 | (t a))) |
| 700 | ) | ||
| 701 | 644 | ||
| 702 | (defun math-to-radians-2 (a) ; [N N] | 645 | (defun math-to-radians-2 (a) ; [N N] |
| 703 | (cond ((eq (car-safe a) 'hms) | 646 | (cond ((eq (car-safe a) 'hms) |
| @@ -706,16 +649,14 @@ | |||
| 706 | (if calc-symbolic-mode | 649 | (if calc-symbolic-mode |
| 707 | (math-div (math-mul a '(var pi var-pi)) 180) | 650 | (math-div (math-mul a '(var pi var-pi)) 180) |
| 708 | (math-mul a (math-pi-over-180)))) | 651 | (math-mul a (math-pi-over-180)))) |
| 709 | (t a)) | 652 | (t a))) |
| 710 | ) | ||
| 711 | 653 | ||
| 712 | (defun math-from-radians-2 (a) ; [N N] | 654 | (defun math-from-radians-2 (a) ; [N N] |
| 713 | (cond ((memq calc-angle-mode '(deg hms)) | 655 | (cond ((memq calc-angle-mode '(deg hms)) |
| 714 | (if calc-symbolic-mode | 656 | (if calc-symbolic-mode |
| 715 | (math-div (math-mul 180 a) '(var pi var-pi)) | 657 | (math-div (math-mul 180 a) '(var pi var-pi)) |
| 716 | (math-div a (math-pi-over-180)))) | 658 | (math-div a (math-pi-over-180)))) |
| 717 | (t a)) | 659 | (t a))) |
| 718 | ) | ||
| 719 | 660 | ||
| 720 | 661 | ||
| 721 | 662 | ||
| @@ -744,8 +685,7 @@ | |||
| 744 | ((equal x '(var nan var-nan)) | 685 | ((equal x '(var nan var-nan)) |
| 745 | x) | 686 | x) |
| 746 | (t (calc-record-why 'scalarp x) | 687 | (t (calc-record-why 'scalarp x) |
| 747 | (list 'calcFunc-sin x))) | 688 | (list 'calcFunc-sin x)))) |
| 748 | ) | ||
| 749 | 689 | ||
| 750 | (defun calcFunc-cos (x) ; [N N] [Public] | 690 | (defun calcFunc-cos (x) ; [N N] [Public] |
| 751 | (cond ((and (integerp x) | 691 | (cond ((and (integerp x) |
| @@ -788,16 +728,14 @@ | |||
| 788 | ((equal x '(var nan var-nan)) | 728 | ((equal x '(var nan var-nan)) |
| 789 | x) | 729 | x) |
| 790 | (t (calc-record-why 'scalarp x) | 730 | (t (calc-record-why 'scalarp x) |
| 791 | (list 'calcFunc-cos x))) | 731 | (list 'calcFunc-cos x)))) |
| 792 | ) | ||
| 793 | 732 | ||
| 794 | (defun calcFunc-sincos (x) ; [V N] [Public] | 733 | (defun calcFunc-sincos (x) ; [V N] [Public] |
| 795 | (if (Math-scalarp x) | 734 | (if (Math-scalarp x) |
| 796 | (math-with-extra-prec 2 | 735 | (math-with-extra-prec 2 |
| 797 | (let ((sc (math-sin-cos-raw (math-to-radians (math-float x))))) | 736 | (let ((sc (math-sin-cos-raw (math-to-radians (math-float x))))) |
| 798 | (list 'vec (cdr sc) (car sc)))) ; the vector [cos, sin] | 737 | (list 'vec (cdr sc) (car sc)))) ; the vector [cos, sin] |
| 799 | (list 'vec (calcFunc-sin x) (calcFunc-cos x))) | 738 | (list 'vec (calcFunc-sin x) (calcFunc-cos x)))) |
| 800 | ) | ||
| 801 | 739 | ||
| 802 | (defun calcFunc-tan (x) ; [N N] [Public] | 740 | (defun calcFunc-tan (x) ; [N N] [Public] |
| 803 | (cond ((and (integerp x) | 741 | (cond ((and (integerp x) |
| @@ -840,8 +778,7 @@ | |||
| 840 | ((equal x '(var nan var-nan)) | 778 | ((equal x '(var nan var-nan)) |
| 841 | x) | 779 | x) |
| 842 | (t (calc-record-why 'scalarp x) | 780 | (t (calc-record-why 'scalarp x) |
| 843 | (list 'calcFunc-tan x))) | 781 | (list 'calcFunc-tan x)))) |
| 844 | ) | ||
| 845 | 782 | ||
| 846 | (defun math-sin-raw (x) ; [N N] | 783 | (defun math-sin-raw (x) ; [N N] |
| 847 | (cond ((eq (car x) 'cplx) | 784 | (cond ((eq (car x) 'cplx) |
| @@ -861,21 +798,18 @@ | |||
| 861 | (math-neg-float (math-sin-raw (math-neg-float x)))) | 798 | (math-neg-float (math-sin-raw (math-neg-float x)))) |
| 862 | ((math-lessp-float '(float 7 0) x) ; avoid inf loops due to roundoff | 799 | ((math-lessp-float '(float 7 0) x) ; avoid inf loops due to roundoff |
| 863 | (math-sin-raw (math-mod x (math-two-pi)))) | 800 | (math-sin-raw (math-mod x (math-two-pi)))) |
| 864 | (t (math-sin-raw-2 x x))) | 801 | (t (math-sin-raw-2 x x)))) |
| 865 | ) | ||
| 866 | 802 | ||
| 867 | (defun math-cos-raw (x) ; [N N] | 803 | (defun math-cos-raw (x) ; [N N] |
| 868 | (if (eq (car-safe x) 'polar) | 804 | (if (eq (car-safe x) 'polar) |
| 869 | (math-polar (math-cos-raw (math-complex x))) | 805 | (math-polar (math-cos-raw (math-complex x))) |
| 870 | (math-sin-raw (math-sub (math-pi-over-2) x))) | 806 | (math-sin-raw (math-sub (math-pi-over-2) x)))) |
| 871 | ) | ||
| 872 | 807 | ||
| 873 | ;;; This could use a smarter method: Reduce x as in math-sin-raw, then | 808 | ;;; This could use a smarter method: Reduce x as in math-sin-raw, then |
| 874 | ;;; compute either sin(x) or cos(x), whichever is smaller, and compute | 809 | ;;; compute either sin(x) or cos(x), whichever is smaller, and compute |
| 875 | ;;; the other using the identity sin(x)^2 + cos(x)^2 = 1. | 810 | ;;; the other using the identity sin(x)^2 + cos(x)^2 = 1. |
| 876 | (defun math-sin-cos-raw (x) ; [F.F F] (result is (sin x . cos x)) | 811 | (defun math-sin-cos-raw (x) ; [F.F F] (result is (sin x . cos x)) |
| 877 | (cons (math-sin-raw x) (math-cos-raw x)) | 812 | (cons (math-sin-raw x) (math-cos-raw x))) |
| 878 | ) | ||
| 879 | 813 | ||
| 880 | (defun math-tan-raw (x) ; [N N] | 814 | (defun math-tan-raw (x) ; [N N] |
| 881 | (cond ((eq (car x) 'cplx) | 815 | (cond ((eq (car x) 'cplx) |
| @@ -898,8 +832,7 @@ | |||
| 898 | (let ((sc (math-sin-cos-raw x))) | 832 | (let ((sc (math-sin-cos-raw x))) |
| 899 | (if (eq (nth 1 (cdr sc)) 0) | 833 | (if (eq (nth 1 (cdr sc)) 0) |
| 900 | (math-div (car sc) 0) | 834 | (math-div (car sc) 0) |
| 901 | (math-div-float (car sc) (cdr sc)))))) | 835 | (math-div-float (car sc) (cdr sc))))))) |
| 902 | ) | ||
| 903 | 836 | ||
| 904 | (defun math-sin-raw-2 (x orgx) ; This avoids poss of inf recursion. [F F] | 837 | (defun math-sin-raw-2 (x orgx) ; This avoids poss of inf recursion. [F F] |
| 905 | (let ((xmpo2 (math-sub-float (math-pi-over-2) x))) | 838 | (let ((xmpo2 (math-sub-float (math-pi-over-2) x))) |
| @@ -912,8 +845,7 @@ | |||
| 912 | (math-neg (math-cos-raw-2 (math-add (math-pi-over-2) x) orgx))) | 845 | (math-neg (math-cos-raw-2 (math-add (math-pi-over-2) x) orgx))) |
| 913 | ((math-nearly-zerop-float x orgx) '(float 0 0)) | 846 | ((math-nearly-zerop-float x orgx) '(float 0 0)) |
| 914 | (calc-symbolic-mode (signal 'inexact-result nil)) | 847 | (calc-symbolic-mode (signal 'inexact-result nil)) |
| 915 | (t (math-sin-series x 6 4 x (math-neg-float (math-sqr-float x)))))) | 848 | (t (math-sin-series x 6 4 x (math-neg-float (math-sqr-float x))))))) |
| 916 | ) | ||
| 917 | 849 | ||
| 918 | (defun math-cos-raw-2 (x orgx) ; [F F] | 850 | (defun math-cos-raw-2 (x orgx) ; [F F] |
| 919 | (cond ((math-nearly-zerop-float x orgx) '(float 1 0)) | 851 | (cond ((math-nearly-zerop-float x orgx) '(float 1 0)) |
| @@ -922,8 +854,7 @@ | |||
| 922 | (math-sin-series | 854 | (math-sin-series |
| 923 | (math-add-float '(float 1 0) | 855 | (math-add-float '(float 1 0) |
| 924 | (math-mul-float xnegsqr '(float 5 -1))) | 856 | (math-mul-float xnegsqr '(float 5 -1))) |
| 925 | 24 5 xnegsqr xnegsqr)))) | 857 | 24 5 xnegsqr xnegsqr))))) |
| 926 | ) | ||
| 927 | 858 | ||
| 928 | (defun math-sin-series (sum nfac n x xnegsqr) | 859 | (defun math-sin-series (sum nfac n x xnegsqr) |
| 929 | (math-working "sin" sum) | 860 | (math-working "sin" sum) |
| @@ -933,8 +864,7 @@ | |||
| 933 | (if (math-nearly-equal-float sum nextsum) | 864 | (if (math-nearly-equal-float sum nextsum) |
| 934 | sum | 865 | sum |
| 935 | (math-sin-series nextsum (math-mul nfac (* n (1+ n))) | 866 | (math-sin-series nextsum (math-mul nfac (* n (1+ n))) |
| 936 | (+ n 2) nextx xnegsqr))) | 867 | (+ n 2) nextx xnegsqr)))) |
| 937 | ) | ||
| 938 | 868 | ||
| 939 | 869 | ||
| 940 | ;;; Inverse sine, cosine, tangent. | 870 | ;;; Inverse sine, cosine, tangent. |
| @@ -960,8 +890,7 @@ | |||
| 960 | ((equal x '(var nan var-nan)) | 890 | ((equal x '(var nan var-nan)) |
| 961 | x) | 891 | x) |
| 962 | (t (calc-record-why 'numberp x) | 892 | (t (calc-record-why 'numberp x) |
| 963 | (list 'calcFunc-arcsin x))) | 893 | (list 'calcFunc-arcsin x)))) |
| 964 | ) | ||
| 965 | 894 | ||
| 966 | (defun calcFunc-arccos (x) ; [N N] [Public] | 895 | (defun calcFunc-arccos (x) ; [N N] [Public] |
| 967 | (cond ((eq x 1) 0) | 896 | (cond ((eq x 1) 0) |
| @@ -984,8 +913,7 @@ | |||
| 984 | ((equal x '(var nan var-nan)) | 913 | ((equal x '(var nan var-nan)) |
| 985 | x) | 914 | x) |
| 986 | (t (calc-record-why 'numberp x) | 915 | (t (calc-record-why 'numberp x) |
| 987 | (list 'calcFunc-arccos x))) | 916 | (list 'calcFunc-arccos x)))) |
| 988 | ) | ||
| 989 | 917 | ||
| 990 | (defun calcFunc-arctan (x) ; [N N] [Public] | 918 | (defun calcFunc-arctan (x) ; [N N] [Public] |
| 991 | (cond ((eq x 0) 0) | 919 | (cond ((eq x 0) 0) |
| @@ -1010,8 +938,7 @@ | |||
| 1010 | ((equal x '(var nan var-nan)) | 938 | ((equal x '(var nan var-nan)) |
| 1011 | x) | 939 | x) |
| 1012 | (t (calc-record-why 'numberp x) | 940 | (t (calc-record-why 'numberp x) |
| 1013 | (list 'calcFunc-arctan x))) | 941 | (list 'calcFunc-arctan x)))) |
| 1014 | ) | ||
| 1015 | 942 | ||
| 1016 | (defun math-arcsin-raw (x) ; [N N] | 943 | (defun math-arcsin-raw (x) ; [N N] |
| 1017 | (let ((a (math-sqrt-raw (math-sub '(float 1 0) (math-sqr x))))) | 944 | (let ((a (math-sqrt-raw (math-sub '(float 1 0) (math-sqr x))))) |
| @@ -1020,12 +947,10 @@ | |||
| 1020 | (math-with-extra-prec 2 ; use extra precision for difficult case | 947 | (math-with-extra-prec 2 ; use extra precision for difficult case |
| 1021 | (math-mul '(cplx 0 -1) | 948 | (math-mul '(cplx 0 -1) |
| 1022 | (math-ln-raw (math-add (math-mul '(cplx 0 1) x) a)))) | 949 | (math-ln-raw (math-add (math-mul '(cplx 0 1) x) a)))) |
| 1023 | (math-arctan2-raw x a))) | 950 | (math-arctan2-raw x a)))) |
| 1024 | ) | ||
| 1025 | 951 | ||
| 1026 | (defun math-arccos-raw (x) ; [N N] | 952 | (defun math-arccos-raw (x) ; [N N] |
| 1027 | (math-sub (math-pi-over-2) (math-arcsin-raw x)) | 953 | (math-sub (math-pi-over-2) (math-arcsin-raw x))) |
| 1028 | ) | ||
| 1029 | 954 | ||
| 1030 | (defun math-arctan-raw (x) ; [N N] | 955 | (defun math-arctan-raw (x) ; [N N] |
| 1031 | (cond ((memq (car x) '(cplx polar)) | 956 | (cond ((memq (car x) '(cplx polar)) |
| @@ -1049,8 +974,7 @@ | |||
| 1049 | (math-sub-float '(float 1 0) x) | 974 | (math-sub-float '(float 1 0) x) |
| 1050 | (math-add-float '(float 1 0) | 975 | (math-add-float '(float 1 0) |
| 1051 | x)))))) | 976 | x)))))) |
| 1052 | (t (math-arctan-series x 3 x (math-neg-float (math-sqr-float x))))) | 977 | (t (math-arctan-series x 3 x (math-neg-float (math-sqr-float x)))))) |
| 1053 | ) | ||
| 1054 | 978 | ||
| 1055 | (defun math-arctan-series (sum n x xnegsqr) | 979 | (defun math-arctan-series (sum n x xnegsqr) |
| 1056 | (math-working "arctan" sum) | 980 | (math-working "arctan" sum) |
| @@ -1058,8 +982,7 @@ | |||
| 1058 | (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) | 982 | (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) |
| 1059 | (if (math-nearly-equal-float sum nextsum) | 983 | (if (math-nearly-equal-float sum nextsum) |
| 1060 | sum | 984 | sum |
| 1061 | (math-arctan-series nextsum (+ n 2) nextx xnegsqr))) | 985 | (math-arctan-series nextsum (+ n 2) nextx xnegsqr)))) |
| 1062 | ) | ||
| 1063 | 986 | ||
| 1064 | (defun calcFunc-arctan2 (y x) ; [F R R] [Public] | 987 | (defun calcFunc-arctan2 (y x) ; [F R R] [Public] |
| 1065 | (if (Math-anglep y) | 988 | (if (Math-anglep y) |
| @@ -1088,8 +1011,7 @@ | |||
| 1088 | (calcFunc-arctan2 y x) | 1011 | (calcFunc-arctan2 y x) |
| 1089 | '(var nan var-nan))) | 1012 | '(var nan var-nan))) |
| 1090 | (calc-record-why 'anglep y) | 1013 | (calc-record-why 'anglep y) |
| 1091 | (list 'calcFunc-arctan2 y x))) | 1014 | (list 'calcFunc-arctan2 y x)))) |
| 1092 | ) | ||
| 1093 | 1015 | ||
| 1094 | (defun math-arctan2-raw (y x) ; [F R R] | 1016 | (defun math-arctan2-raw (y x) ; [F R R] |
| 1095 | (cond ((math-zerop y) | 1017 | (cond ((math-zerop y) |
| @@ -1106,15 +1028,13 @@ | |||
| 1106 | (math-pi))) | 1028 | (math-pi))) |
| 1107 | (t | 1029 | (t |
| 1108 | (math-sub-float (math-arctan-raw (math-div-float y x)) | 1030 | (math-sub-float (math-arctan-raw (math-div-float y x)) |
| 1109 | (math-pi)))) | 1031 | (math-pi))))) |
| 1110 | ) | ||
| 1111 | 1032 | ||
| 1112 | (defun calcFunc-arcsincos (x) ; [V N] [Public] | 1033 | (defun calcFunc-arcsincos (x) ; [V N] [Public] |
| 1113 | (if (and (Math-vectorp x) | 1034 | (if (and (Math-vectorp x) |
| 1114 | (= (length x) 3)) | 1035 | (= (length x) 3)) |
| 1115 | (calcFunc-arctan2 (nth 2 x) (nth 1 x)) | 1036 | (calcFunc-arctan2 (nth 2 x) (nth 1 x)) |
| 1116 | (math-reject-arg x "*Two-element vector expected")) | 1037 | (math-reject-arg x "*Two-element vector expected"))) |
| 1117 | ) | ||
| 1118 | 1038 | ||
| 1119 | 1039 | ||
| 1120 | 1040 | ||
| @@ -1139,8 +1059,7 @@ | |||
| 1139 | ((equal x '(var nan var-nan)) | 1059 | ((equal x '(var nan var-nan)) |
| 1140 | x) | 1060 | x) |
| 1141 | (t (calc-record-why 'numberp x) | 1061 | (t (calc-record-why 'numberp x) |
| 1142 | (list 'calcFunc-exp x))) | 1062 | (list 'calcFunc-exp x)))) |
| 1143 | ) | ||
| 1144 | 1063 | ||
| 1145 | (defun calcFunc-expm1 (x) ; [N N] [Public] | 1064 | (defun calcFunc-expm1 (x) ; [N N] [Public] |
| 1146 | (cond ((eq x 0) 0) | 1065 | (cond ((eq x 0) 0) |
| @@ -1171,14 +1090,12 @@ | |||
| 1171 | ((equal x '(var nan var-nan)) | 1090 | ((equal x '(var nan var-nan)) |
| 1172 | x) | 1091 | x) |
| 1173 | (t (calc-record-why 'numberp x) | 1092 | (t (calc-record-why 'numberp x) |
| 1174 | (list 'calcFunc-expm1 x))) | 1093 | (list 'calcFunc-expm1 x)))) |
| 1175 | ) | ||
| 1176 | 1094 | ||
| 1177 | (defun calcFunc-exp10 (x) ; [N N] [Public] | 1095 | (defun calcFunc-exp10 (x) ; [N N] [Public] |
| 1178 | (if (eq x 0) | 1096 | (if (eq x 0) |
| 1179 | 1 | 1097 | 1 |
| 1180 | (math-pow '(float 1 1) x)) | 1098 | (math-pow '(float 1 1) x))) |
| 1181 | ) | ||
| 1182 | 1099 | ||
| 1183 | (defun math-exp-raw (x) ; [N N] | 1100 | (defun math-exp-raw (x) ; [N N] |
| 1184 | (cond ((math-zerop x) '(float 1 0)) | 1101 | (cond ((math-zerop x) '(float 1 0)) |
| @@ -1207,12 +1124,10 @@ | |||
| 1207 | (math-mul-float (math-ipow (math-sqrt-e) hint) | 1124 | (math-mul-float (math-ipow (math-sqrt-e) hint) |
| 1208 | (math-add-float '(float 1 0) | 1125 | (math-add-float '(float 1 0) |
| 1209 | (math-exp-minus-1-raw hfrac))))) | 1126 | (math-exp-minus-1-raw hfrac))))) |
| 1210 | (t (math-add-float '(float 1 0) (math-exp-minus-1-raw x)))) | 1127 | (t (math-add-float '(float 1 0) (math-exp-minus-1-raw x))))) |
| 1211 | ) | ||
| 1212 | 1128 | ||
| 1213 | (defun math-exp-minus-1-raw (x) ; [F F] | 1129 | (defun math-exp-minus-1-raw (x) ; [F F] |
| 1214 | (math-exp-series x 2 3 x x) | 1130 | (math-exp-series x 2 3 x x)) |
| 1215 | ) | ||
| 1216 | 1131 | ||
| 1217 | (defun math-exp-series (sum nfac n xpow x) | 1132 | (defun math-exp-series (sum nfac n xpow x) |
| 1218 | (math-working "exp" sum) | 1133 | (math-working "exp" sum) |
| @@ -1221,8 +1136,7 @@ | |||
| 1221 | (math-float nfac))))) | 1136 | (math-float nfac))))) |
| 1222 | (if (math-nearly-equal-float sum nextsum) | 1137 | (if (math-nearly-equal-float sum nextsum) |
| 1223 | sum | 1138 | sum |
| 1224 | (math-exp-series nextsum (math-mul nfac n) (1+ n) nextx x))) | 1139 | (math-exp-series nextsum (math-mul nfac n) (1+ n) nextx x)))) |
| 1225 | ) | ||
| 1226 | 1140 | ||
| 1227 | 1141 | ||
| 1228 | 1142 | ||
| @@ -1256,8 +1170,7 @@ | |||
| 1256 | x | 1170 | x |
| 1257 | '(var inf var-inf))) | 1171 | '(var inf var-inf))) |
| 1258 | (t (calc-record-why 'numberp x) | 1172 | (t (calc-record-why 'numberp x) |
| 1259 | (list 'calcFunc-ln x))) | 1173 | (list 'calcFunc-ln x)))) |
| 1260 | ) | ||
| 1261 | 1174 | ||
| 1262 | (defun calcFunc-log10 (x) ; [N N] [Public] | 1175 | (defun calcFunc-log10 (x) ; [N N] [Public] |
| 1263 | (cond ((math-equal-int x 1) | 1176 | (cond ((math-equal-int x 1) |
| @@ -1308,8 +1221,7 @@ | |||
| 1308 | x | 1221 | x |
| 1309 | '(var inf var-inf))) | 1222 | '(var inf var-inf))) |
| 1310 | (t (calc-record-why 'numberp x) | 1223 | (t (calc-record-why 'numberp x) |
| 1311 | (list 'calcFunc-log10 x))) | 1224 | (list 'calcFunc-log10 x)))) |
| 1312 | ) | ||
| 1313 | 1225 | ||
| 1314 | (defun calcFunc-log (x &optional b) ; [N N N] [Public] | 1226 | (defun calcFunc-log (x &optional b) ; [N N N] [Public] |
| 1315 | (cond ((or (null b) (equal b '(var e var-e))) | 1227 | (cond ((or (null b) (equal b '(var e var-e))) |
| @@ -1374,14 +1286,12 @@ | |||
| 1374 | (t (if (Math-numberp b) | 1286 | (t (if (Math-numberp b) |
| 1375 | (calc-record-why 'numberp x) | 1287 | (calc-record-why 'numberp x) |
| 1376 | (calc-record-why 'numberp b)) | 1288 | (calc-record-why 'numberp b)) |
| 1377 | (list 'calcFunc-log x b))) | 1289 | (list 'calcFunc-log x b)))) |
| 1378 | ) | ||
| 1379 | 1290 | ||
| 1380 | (defun calcFunc-alog (x &optional b) | 1291 | (defun calcFunc-alog (x &optional b) |
| 1381 | (cond ((or (null b) (equal b '(var e var-e))) | 1292 | (cond ((or (null b) (equal b '(var e var-e))) |
| 1382 | (math-normalize (list 'calcFunc-exp x))) | 1293 | (math-normalize (list 'calcFunc-exp x))) |
| 1383 | (t (math-pow b x))) | 1294 | (t (math-pow b x)))) |
| 1384 | ) | ||
| 1385 | 1295 | ||
| 1386 | (defun calcFunc-ilog (x b) | 1296 | (defun calcFunc-ilog (x b) |
| 1387 | (if (and (math-natnump x) (not (eq x 0)) | 1297 | (if (and (math-natnump x) (not (eq x 0)) |
| @@ -1391,8 +1301,7 @@ | |||
| 1391 | (if (Math-natnum-lessp x b) | 1301 | (if (Math-natnum-lessp x b) |
| 1392 | 0 | 1302 | 0 |
| 1393 | (cdr (math-integer-log x b)))) | 1303 | (cdr (math-integer-log x b)))) |
| 1394 | (math-floor (calcFunc-log x b))) | 1304 | (math-floor (calcFunc-log x b)))) |
| 1395 | ) | ||
| 1396 | 1305 | ||
| 1397 | (defun math-integer-log (x b) | 1306 | (defun math-integer-log (x b) |
| 1398 | (let ((pows (list b)) | 1307 | (let ((pows (list b)) |
| @@ -1412,8 +1321,7 @@ | |||
| 1412 | (or (Math-lessp x next) | 1321 | (or (Math-lessp x next) |
| 1413 | (setq pow next | 1322 | (setq pow next |
| 1414 | sum (+ sum n)))) | 1323 | sum (+ sum n)))) |
| 1415 | (cons (equal pow x) sum)) | 1324 | (cons (equal pow x) sum))) |
| 1416 | ) | ||
| 1417 | 1325 | ||
| 1418 | 1326 | ||
| 1419 | (defun math-log-base-raw (b) ; [N N] | 1327 | (defun math-log-base-raw (b) ; [N N] |
| @@ -1421,8 +1329,7 @@ | |||
| 1421 | (eq (nth 1 math-log-base-cache) calc-internal-prec))) | 1329 | (eq (nth 1 math-log-base-cache) calc-internal-prec))) |
| 1422 | (setq math-log-base-cache (list b calc-internal-prec | 1330 | (setq math-log-base-cache (list b calc-internal-prec |
| 1423 | (math-ln-raw (math-float b))))) | 1331 | (math-ln-raw (math-float b))))) |
| 1424 | (nth 2 math-log-base-cache) | 1332 | (nth 2 math-log-base-cache)) |
| 1425 | ) | ||
| 1426 | (setq math-log-base-cache nil) | 1333 | (setq math-log-base-cache nil) |
| 1427 | 1334 | ||
| 1428 | (defun calcFunc-lnp1 (x) ; [N N] [Public] | 1335 | (defun calcFunc-lnp1 (x) ; [N N] [Public] |
| @@ -1454,8 +1361,7 @@ | |||
| 1454 | x | 1361 | x |
| 1455 | '(var inf var-inf))) | 1362 | '(var inf var-inf))) |
| 1456 | (t (calc-record-why 'numberp x) | 1363 | (t (calc-record-why 'numberp x) |
| 1457 | (list 'calcFunc-lnp1 x))) | 1364 | (list 'calcFunc-lnp1 x)))) |
| 1458 | ) | ||
| 1459 | 1365 | ||
| 1460 | (defun math-ln-raw (x) ; [N N] --- must be float format! | 1366 | (defun math-ln-raw (x) ; [N N] --- must be float format! |
| 1461 | (cond ((eq (car-safe x) 'cplx) | 1367 | (cond ((eq (car-safe x) 'cplx) |
| @@ -1486,8 +1392,7 @@ | |||
| 1486 | (math-pi)))) | 1392 | (math-pi)))) |
| 1487 | (t (list 'cplx ; negative and real | 1393 | (t (list 'cplx ; negative and real |
| 1488 | (math-ln-raw (math-neg-float x)) | 1394 | (math-ln-raw (math-neg-float x)) |
| 1489 | (math-pi)))) | 1395 | (math-pi))))) |
| 1490 | ) | ||
| 1491 | 1396 | ||
| 1492 | (defun math-ln-raw-2 (x) ; [F F] | 1397 | (defun math-ln-raw-2 (x) ; [F F] |
| 1493 | (cond ((math-lessp-float '(float 14 -1) x) | 1398 | (cond ((math-lessp-float '(float 14 -1) x) |
| @@ -1495,13 +1400,11 @@ | |||
| 1495 | (math-ln-2))) | 1400 | (math-ln-2))) |
| 1496 | (t ; now .7 < x <= 1.4 | 1401 | (t ; now .7 < x <= 1.4 |
| 1497 | (math-ln-raw-3 (math-div-float (math-sub-float x '(float 1 0)) | 1402 | (math-ln-raw-3 (math-div-float (math-sub-float x '(float 1 0)) |
| 1498 | (math-add-float x '(float 1 0)))))) | 1403 | (math-add-float x '(float 1 0))))))) |
| 1499 | ) | ||
| 1500 | 1404 | ||
| 1501 | (defun math-ln-raw-3 (x) ; [F F] | 1405 | (defun math-ln-raw-3 (x) ; [F F] |
| 1502 | (math-mul-float (math-ln-raw-series x 3 x (math-sqr-float x)) | 1406 | (math-mul-float (math-ln-raw-series x 3 x (math-sqr-float x)) |
| 1503 | '(float 2 0)) | 1407 | '(float 2 0))) |
| 1504 | ) | ||
| 1505 | 1408 | ||
| 1506 | ;;; Compute ln((1+x)/(1-x)) | 1409 | ;;; Compute ln((1+x)/(1-x)) |
| 1507 | (defun math-ln-raw-series (sum n x xsqr) | 1410 | (defun math-ln-raw-series (sum n x xsqr) |
| @@ -1510,12 +1413,10 @@ | |||
| 1510 | (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) | 1413 | (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) |
| 1511 | (if (math-nearly-equal-float sum nextsum) | 1414 | (if (math-nearly-equal-float sum nextsum) |
| 1512 | sum | 1415 | sum |
| 1513 | (math-ln-raw-series nextsum (+ n 2) nextx xsqr))) | 1416 | (math-ln-raw-series nextsum (+ n 2) nextx xsqr)))) |
| 1514 | ) | ||
| 1515 | 1417 | ||
| 1516 | (defun math-ln-plus-1-raw (x) | 1418 | (defun math-ln-plus-1-raw (x) |
| 1517 | (math-lnp1-series x 2 x (math-neg x)) | 1419 | (math-lnp1-series x 2 x (math-neg x))) |
| 1518 | ) | ||
| 1519 | 1420 | ||
| 1520 | (defun math-lnp1-series (sum n xpow x) | 1421 | (defun math-lnp1-series (sum n xpow x) |
| 1521 | (math-working "lnp1" sum) | 1422 | (math-working "lnp1" sum) |
| @@ -1523,8 +1424,7 @@ | |||
| 1523 | (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) | 1424 | (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) |
| 1524 | (if (math-nearly-equal-float sum nextsum) | 1425 | (if (math-nearly-equal-float sum nextsum) |
| 1525 | sum | 1426 | sum |
| 1526 | (math-lnp1-series nextsum (1+ n) nextx x))) | 1427 | (math-lnp1-series nextsum (1+ n) nextx x)))) |
| 1527 | ) | ||
| 1528 | 1428 | ||
| 1529 | (math-defcache math-ln-10 (float (bigpos 018 684 045 994 092 585 302 2) -21) | 1429 | (math-defcache math-ln-10 (float (bigpos 018 684 045 994 092 585 302 2) -21) |
| 1530 | (math-ln-raw-2 '(float 1 1))) | 1430 | (math-ln-raw-2 '(float 1 1))) |
| @@ -1559,8 +1459,7 @@ | |||
| 1559 | (equal x '(var nan var-nan))) | 1459 | (equal x '(var nan var-nan))) |
| 1560 | x) | 1460 | x) |
| 1561 | (t (calc-record-why 'numberp x) | 1461 | (t (calc-record-why 'numberp x) |
| 1562 | (list 'calcFunc-sinh x))) | 1462 | (list 'calcFunc-sinh x)))) |
| 1563 | ) | ||
| 1564 | (put 'calcFunc-sinh 'math-expandable t) | 1463 | (put 'calcFunc-sinh 'math-expandable t) |
| 1565 | 1464 | ||
| 1566 | (defun calcFunc-cosh (x) ; [N N] [Public] | 1465 | (defun calcFunc-cosh (x) ; [N N] [Public] |
| @@ -1588,8 +1487,7 @@ | |||
| 1588 | (equal x '(var nan var-nan))) | 1487 | (equal x '(var nan var-nan))) |
| 1589 | (math-abs x)) | 1488 | (math-abs x)) |
| 1590 | (t (calc-record-why 'numberp x) | 1489 | (t (calc-record-why 'numberp x) |
| 1591 | (list 'calcFunc-cosh x))) | 1490 | (list 'calcFunc-cosh x)))) |
| 1592 | ) | ||
| 1593 | (put 'calcFunc-cosh 'math-expandable t) | 1491 | (put 'calcFunc-cosh 'math-expandable t) |
| 1594 | 1492 | ||
| 1595 | (defun calcFunc-tanh (x) ; [N N] [Public] | 1493 | (defun calcFunc-tanh (x) ; [N N] [Public] |
| @@ -1622,8 +1520,7 @@ | |||
| 1622 | ((equal x '(var nan var-nan)) | 1520 | ((equal x '(var nan var-nan)) |
| 1623 | x) | 1521 | x) |
| 1624 | (t (calc-record-why 'numberp x) | 1522 | (t (calc-record-why 'numberp x) |
| 1625 | (list 'calcFunc-tanh x))) | 1523 | (list 'calcFunc-tanh x)))) |
| 1626 | ) | ||
| 1627 | (put 'calcFunc-tanh 'math-expandable t) | 1524 | (put 'calcFunc-tanh 'math-expandable t) |
| 1628 | 1525 | ||
| 1629 | (defun calcFunc-arcsinh (x) ; [N N] [Public] | 1526 | (defun calcFunc-arcsinh (x) ; [N N] [Public] |
| @@ -1651,8 +1548,7 @@ | |||
| 1651 | (equal x '(var nan var-nan))) | 1548 | (equal x '(var nan var-nan))) |
| 1652 | x) | 1549 | x) |
| 1653 | (t (calc-record-why 'numberp x) | 1550 | (t (calc-record-why 'numberp x) |
| 1654 | (list 'calcFunc-arcsinh x))) | 1551 | (list 'calcFunc-arcsinh x)))) |
| 1655 | ) | ||
| 1656 | (put 'calcFunc-arcsinh 'math-expandable t) | 1552 | (put 'calcFunc-arcsinh 'math-expandable t) |
| 1657 | 1553 | ||
| 1658 | (defun calcFunc-arccosh (x) ; [N N] [Public] | 1554 | (defun calcFunc-arccosh (x) ; [N N] [Public] |
| @@ -1697,8 +1593,7 @@ | |||
| 1697 | (equal x '(var nan var-nan))) | 1593 | (equal x '(var nan var-nan))) |
| 1698 | x) | 1594 | x) |
| 1699 | (t (calc-record-why 'numberp x) | 1595 | (t (calc-record-why 'numberp x) |
| 1700 | (list 'calcFunc-arccosh x))) | 1596 | (list 'calcFunc-arccosh x)))) |
| 1701 | ) | ||
| 1702 | (put 'calcFunc-arccosh 'math-expandable t) | 1597 | (put 'calcFunc-arccosh 'math-expandable t) |
| 1703 | 1598 | ||
| 1704 | (defun calcFunc-arctanh (x) ; [N N] [Public] | 1599 | (defun calcFunc-arctanh (x) ; [N N] [Public] |
| @@ -1737,8 +1632,7 @@ | |||
| 1737 | ((equal x '(var nan var-nan)) | 1632 | ((equal x '(var nan var-nan)) |
| 1738 | x) | 1633 | x) |
| 1739 | (t (calc-record-why 'numberp x) | 1634 | (t (calc-record-why 'numberp x) |
| 1740 | (list 'calcFunc-arctanh x))) | 1635 | (list 'calcFunc-arctanh x)))) |
| 1741 | ) | ||
| 1742 | (put 'calcFunc-arctanh 'math-expandable t) | 1636 | (put 'calcFunc-arctanh 'math-expandable t) |
| 1743 | 1637 | ||
| 1744 | 1638 | ||
| @@ -1756,8 +1650,7 @@ | |||
| 1756 | (math-expand-formulas | 1650 | (math-expand-formulas |
| 1757 | (math-div (math-mul a '(var pi var-pi)) 180)) | 1651 | (math-div (math-mul a '(var pi var-pi)) 180)) |
| 1758 | ((math-infinitep a) a) | 1652 | ((math-infinitep a) a) |
| 1759 | (t (list 'calcFunc-rad a))) | 1653 | (t (list 'calcFunc-rad a)))) |
| 1760 | ) | ||
| 1761 | (put 'calcFunc-rad 'math-expandable t) | 1654 | (put 'calcFunc-rad 'math-expandable t) |
| 1762 | 1655 | ||
| 1763 | ;;; Convert A from HMS or radians to degrees. | 1656 | ;;; Convert A from HMS or radians to degrees. |
| @@ -1774,10 +1667,9 @@ | |||
| 1774 | (math-expand-formulas | 1667 | (math-expand-formulas |
| 1775 | (math-div (math-mul 180 a) '(var pi var-pi))) | 1668 | (math-div (math-mul 180 a) '(var pi var-pi))) |
| 1776 | ((math-infinitep a) a) | 1669 | ((math-infinitep a) a) |
| 1777 | (t (list 'calcFunc-deg a))) | 1670 | (t (list 'calcFunc-deg a)))) |
| 1778 | ) | ||
| 1779 | (put 'calcFunc-deg 'math-expandable t) | 1671 | (put 'calcFunc-deg 'math-expandable t) |
| 1780 | 1672 | ||
| 1781 | 1673 | ;;; calc-math.el ends here | |
| 1782 | 1674 | ||
| 1783 | 1675 | ||