Mercurial > emacs
annotate lisp/calc/calc-math.el @ 97528:184bb2071e3f
mail/: Add new (temporary) libaries for which to test Rmail/mbox such
that Rmail/babyl is not affected. This creates a facility/feature
called "pmail" (analagous to "rmail") that can be used independently
from Rmail for testing purposes. The plan is to replace the "rmail"
files eventually and remove "pmail" entirely at that point. In the
interim, interested developers can use either Rmail or Pmail or both
(which is not recommended for the casual User or the faint of heart).
author | Paul Reilly <pmr@pajato.com> |
---|---|
date | Mon, 18 Aug 2008 04:51:28 +0000 |
parents | 6c9af2bfcfee |
children | a9dc0e7c3f2b |
rev | line source |
---|---|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41044
diff
changeset
|
1 ;;; calc-math.el --- mathematical functions for Calc |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41044
diff
changeset
|
2 |
64325
1db49616ce05
Update copyright information.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
62165
diff
changeset
|
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, |
79702 | 4 ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41044
diff
changeset
|
5 |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41044
diff
changeset
|
6 ;; Author: David Gillespie <daveg@synaptics.com> |
77465
1154f082efd9
Update maintainer's address.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
76595
diff
changeset
|
7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> |
40785 | 8 |
9 ;; This file is part of GNU Emacs. | |
10 | |
94654
6c9af2bfcfee
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
11 ;; GNU Emacs is free software: you can redistribute it and/or modify |
76595
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
12 ;; it under the terms of the GNU General Public License as published by |
94654
6c9af2bfcfee
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
13 ;; the Free Software Foundation, either version 3 of the License, or |
6c9af2bfcfee
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
14 ;; (at your option) any later version. |
40785 | 15 |
76595
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
16 ;; GNU Emacs is distributed in the hope that it will be useful, |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
19 ;; GNU General Public License for more details. |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
20 |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
21 ;; You should have received a copy of the GNU General Public License |
94654
6c9af2bfcfee
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
40785 | 23 |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41044
diff
changeset
|
24 ;;; Commentary: |
40785 | 25 |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41044
diff
changeset
|
26 ;;; Code: |
40785 | 27 |
28 ;; This file is autoloaded from calc-ext.el. | |
58663
7ed196c06460
Add a provide statement.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58475
diff
changeset
|
29 |
40785 | 30 (require 'calc-ext) |
31 (require 'calc-macs) | |
32 | |
82015
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
33 |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
34 ;;; Find out how many 9s in 9.9999... will give distinct Emacs floats, |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
35 ;;; then back off by one. |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
36 |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
37 (defvar math-emacs-precision |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
38 (let* ((n 1) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
39 (x 9) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
40 (xx (+ x (* 9 (expt 10 (- n)))))) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
41 (while (/= x xx) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
42 (progn |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
43 (setq n (1+ n)) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
44 (setq x xx) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
45 (setq xx (+ x (* 9 (expt 10 (- n))))))) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
46 (1- n)) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
47 "The number of digits in an Emacs float.") |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
48 |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
49 ;;; Find the largest power of 10 which is an Emacs float, |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
50 ;;; then back off by one so that any float d.dddd...eN |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
51 ;;; is an Emacs float, for acceptable d.dddd.... |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
52 |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
53 (defvar math-largest-emacs-expt |
84994
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
54 (let ((x 1) |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
55 (pow 1e2)) |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
56 ;; The following loop is for efficiency; it should stop when |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
57 ;; 10^(2x) is too large. This could be indicated by a range |
85003
155b89cb60fb
(math-largest-emacs-expt): Remove unnecessary condition check.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84994
diff
changeset
|
58 ;; error when computing 10^(2x) or an infinite value for 10^(2x). |
84994
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
59 (while (and |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
60 pow |
85003
155b89cb60fb
(math-largest-emacs-expt): Remove unnecessary condition check.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84994
diff
changeset
|
61 (< pow 1.0e+INF)) |
84994
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
62 (setq x (* 2 x)) |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
63 (setq pow (condition-case nil |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
64 (expt 10.0 (* 2 x)) |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
65 (error nil)))) |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
66 ;; The following loop should stop when 10^(x+1) is too large. |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
67 (setq pow (condition-case nil |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
68 (expt 10.0 (1+ x)) |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
69 (error nil))) |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
70 (while (and |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
71 pow |
85003
155b89cb60fb
(math-largest-emacs-expt): Remove unnecessary condition check.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84994
diff
changeset
|
72 (< pow 1.0e+INF)) |
84994
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
73 (setq x (1+ x)) |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
74 (setq pow (condition-case nil |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
75 (expt 10.0 (1+ x)) |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
76 (error nil)))) |
39018b7044de
calc-math.el (math-largest-emacs-expt): Handle the cases when expt
Jay Belanger <jay.p.belanger@gmail.com>
parents:
84993
diff
changeset
|
77 (1- x)) |
82015
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
78 "The largest exponent which Calc will convert to an Emacs float.") |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
79 |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
80 (defvar math-smallest-emacs-expt |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
81 (let ((x -1)) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
82 (while (condition-case nil |
84993
3788dd19e020
(math-smallest-emacs-expt): Make the computation more robust.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82443
diff
changeset
|
83 (> (expt 10.0 x) 0.0) |
82015
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
84 (error nil)) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
85 (setq x (* 2 x))) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
86 (setq x (/ x 2)) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
87 (while (condition-case nil |
84993
3788dd19e020
(math-smallest-emacs-expt): Make the computation more robust.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82443
diff
changeset
|
88 (> (expt 10.0 x) 0.0) |
82015
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
89 (error nil)) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
90 (setq x (1- x))) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
91 (+ x 2)) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
92 "The smallest exponent which Calc will convert to an Emacs float.") |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
93 |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
94 (defun math-use-emacs-fn (fn x) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
95 "Use the native Emacs function FN to evaluate the Calc number X. |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
96 If this can't be done, return NIL." |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
97 (and |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
98 (<= calc-internal-prec math-emacs-precision) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
99 (math-realp x) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
100 (let* ((fx (math-float x)) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
101 (xpon (+ (nth 2 x) (1- (math-numdigs (nth 1 x)))))) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
102 (and (<= math-smallest-emacs-expt xpon) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
103 (<= xpon math-largest-emacs-expt) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
104 (condition-case nil |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
105 (math-read-number |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
106 (number-to-string |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
107 (funcall fn |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
108 (string-to-number (math-format-number (math-float x)))))) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
109 (error nil)))))) |
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
110 |
40785 | 111 (defun calc-sqrt (arg) |
112 (interactive "P") | |
113 (calc-slow-wrapper | |
114 (if (calc-is-inverse) | |
115 (calc-unary-op "^2" 'calcFunc-sqr arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
116 (calc-unary-op "sqrt" 'calcFunc-sqrt arg)))) |
40785 | 117 |
118 (defun calc-isqrt (arg) | |
119 (interactive "P") | |
120 (calc-slow-wrapper | |
121 (if (calc-is-inverse) | |
122 (calc-unary-op "^2" 'calcFunc-sqr arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
123 (calc-unary-op "isqt" 'calcFunc-isqrt arg)))) |
40785 | 124 |
125 | |
126 (defun calc-hypot (arg) | |
127 (interactive "P") | |
128 (calc-slow-wrapper | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
129 (calc-binary-op "hypt" 'calcFunc-hypot arg))) |
40785 | 130 |
131 (defun calc-ln (arg) | |
132 (interactive "P") | |
133 (calc-invert-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
134 (calc-exp arg)) |
40785 | 135 |
136 (defun calc-log10 (arg) | |
137 (interactive "P") | |
138 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
139 (calc-ln arg)) |
40785 | 140 |
141 (defun calc-log (arg) | |
142 (interactive "P") | |
143 (calc-slow-wrapper | |
144 (if (calc-is-inverse) | |
145 (calc-binary-op "alog" 'calcFunc-alog arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
146 (calc-binary-op "log" 'calcFunc-log arg)))) |
40785 | 147 |
148 (defun calc-ilog (arg) | |
149 (interactive "P") | |
150 (calc-slow-wrapper | |
151 (if (calc-is-inverse) | |
152 (calc-binary-op "alog" 'calcFunc-alog arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
153 (calc-binary-op "ilog" 'calcFunc-ilog arg)))) |
40785 | 154 |
155 (defun calc-lnp1 (arg) | |
156 (interactive "P") | |
157 (calc-invert-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
158 (calc-expm1 arg)) |
40785 | 159 |
160 (defun calc-exp (arg) | |
161 (interactive "P") | |
162 (calc-slow-wrapper | |
163 (if (calc-is-hyperbolic) | |
164 (if (calc-is-inverse) | |
165 (calc-unary-op "lg10" 'calcFunc-log10 arg) | |
166 (calc-unary-op "10^" 'calcFunc-exp10 arg)) | |
167 (if (calc-is-inverse) | |
168 (calc-unary-op "ln" 'calcFunc-ln arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
169 (calc-unary-op "exp" 'calcFunc-exp arg))))) |
40785 | 170 |
171 (defun calc-expm1 (arg) | |
172 (interactive "P") | |
173 (calc-slow-wrapper | |
174 (if (calc-is-inverse) | |
175 (calc-unary-op "ln+1" 'calcFunc-lnp1 arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
176 (calc-unary-op "ex-1" 'calcFunc-expm1 arg)))) |
40785 | 177 |
178 (defun calc-pi () | |
179 (interactive) | |
180 (calc-slow-wrapper | |
181 (if (calc-is-inverse) | |
182 (if (calc-is-hyperbolic) | |
183 (if calc-symbolic-mode | |
184 (calc-pop-push-record 0 "phi" '(var phi var-phi)) | |
185 (calc-pop-push-record 0 "phi" (math-phi))) | |
186 (if calc-symbolic-mode | |
187 (calc-pop-push-record 0 "gmma" '(var gamma var-gamma)) | |
188 (calc-pop-push-record 0 "gmma" (math-gamma-const)))) | |
189 (if (calc-is-hyperbolic) | |
190 (if calc-symbolic-mode | |
191 (calc-pop-push-record 0 "e" '(var e var-e)) | |
192 (calc-pop-push-record 0 "e" (math-e))) | |
193 (if calc-symbolic-mode | |
194 (calc-pop-push-record 0 "pi" '(var pi var-pi)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
195 (calc-pop-push-record 0 "pi" (math-pi))))))) |
40785 | 196 |
197 (defun calc-sin (arg) | |
198 (interactive "P") | |
199 (calc-slow-wrapper | |
200 (if (calc-is-hyperbolic) | |
201 (if (calc-is-inverse) | |
202 (calc-unary-op "asnh" 'calcFunc-arcsinh arg) | |
203 (calc-unary-op "sinh" 'calcFunc-sinh arg)) | |
204 (if (calc-is-inverse) | |
205 (calc-unary-op "asin" 'calcFunc-arcsin arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
206 (calc-unary-op "sin" 'calcFunc-sin arg))))) |
40785 | 207 |
208 (defun calc-arcsin (arg) | |
209 (interactive "P") | |
210 (calc-invert-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
211 (calc-sin arg)) |
40785 | 212 |
213 (defun calc-sinh (arg) | |
214 (interactive "P") | |
215 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
216 (calc-sin arg)) |
40785 | 217 |
218 (defun calc-arcsinh (arg) | |
219 (interactive "P") | |
220 (calc-invert-func) | |
221 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
222 (calc-sin arg)) |
40785 | 223 |
60079
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
224 (defun calc-sec (arg) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
225 (interactive "P") |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
226 (calc-slow-wrapper |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
227 (if (calc-is-hyperbolic) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
228 (calc-unary-op "sech" 'calcFunc-sech arg) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
229 (calc-unary-op "sec" 'calcFunc-sec arg)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
230 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
231 (defun calc-sech (arg) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
232 (interactive "P") |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
233 (calc-hyperbolic-func) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
234 (calc-sec arg)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
235 |
40785 | 236 (defun calc-cos (arg) |
237 (interactive "P") | |
238 (calc-slow-wrapper | |
239 (if (calc-is-hyperbolic) | |
240 (if (calc-is-inverse) | |
241 (calc-unary-op "acsh" 'calcFunc-arccosh arg) | |
242 (calc-unary-op "cosh" 'calcFunc-cosh arg)) | |
243 (if (calc-is-inverse) | |
244 (calc-unary-op "acos" 'calcFunc-arccos arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
245 (calc-unary-op "cos" 'calcFunc-cos arg))))) |
40785 | 246 |
247 (defun calc-arccos (arg) | |
248 (interactive "P") | |
249 (calc-invert-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
250 (calc-cos arg)) |
40785 | 251 |
252 (defun calc-cosh (arg) | |
253 (interactive "P") | |
254 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
255 (calc-cos arg)) |
40785 | 256 |
257 (defun calc-arccosh (arg) | |
258 (interactive "P") | |
259 (calc-invert-func) | |
260 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
261 (calc-cos arg)) |
40785 | 262 |
60079
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
263 (defun calc-csc (arg) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
264 (interactive "P") |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
265 (calc-slow-wrapper |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
266 (if (calc-is-hyperbolic) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
267 (calc-unary-op "csch" 'calcFunc-csch arg) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
268 (calc-unary-op "csc" 'calcFunc-csc arg)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
269 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
270 (defun calc-csch (arg) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
271 (interactive "P") |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
272 (calc-hyperbolic-func) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
273 (calc-csc arg)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
274 |
40785 | 275 (defun calc-sincos () |
276 (interactive) | |
277 (calc-slow-wrapper | |
278 (if (calc-is-inverse) | |
279 (calc-enter-result 1 "asnc" (list 'calcFunc-arcsincos (calc-top-n 1))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
280 (calc-enter-result 1 "sncs" (list 'calcFunc-sincos (calc-top-n 1)))))) |
40785 | 281 |
282 (defun calc-tan (arg) | |
283 (interactive "P") | |
284 (calc-slow-wrapper | |
285 (if (calc-is-hyperbolic) | |
286 (if (calc-is-inverse) | |
287 (calc-unary-op "atnh" 'calcFunc-arctanh arg) | |
288 (calc-unary-op "tanh" 'calcFunc-tanh arg)) | |
289 (if (calc-is-inverse) | |
290 (calc-unary-op "atan" 'calcFunc-arctan arg) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
291 (calc-unary-op "tan" 'calcFunc-tan arg))))) |
40785 | 292 |
293 (defun calc-arctan (arg) | |
294 (interactive "P") | |
295 (calc-invert-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
296 (calc-tan arg)) |
40785 | 297 |
298 (defun calc-tanh (arg) | |
299 (interactive "P") | |
300 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
301 (calc-tan arg)) |
40785 | 302 |
303 (defun calc-arctanh (arg) | |
304 (interactive "P") | |
305 (calc-invert-func) | |
306 (calc-hyperbolic-func) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
307 (calc-tan arg)) |
40785 | 308 |
60079
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
309 (defun calc-cot (arg) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
310 (interactive "P") |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
311 (calc-slow-wrapper |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
312 (if (calc-is-hyperbolic) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
313 (calc-unary-op "coth" 'calcFunc-coth arg) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
314 (calc-unary-op "cot" 'calcFunc-cot arg)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
315 |
60164
697e2ba683cc
(calc-arctan, calc-tanh, calc-arctanh): Removed extra definitions.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
60085
diff
changeset
|
316 (defun calc-coth (arg) |
60079
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
317 (interactive "P") |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
318 (calc-hyperbolic-func) |
60164
697e2ba683cc
(calc-arctan, calc-tanh, calc-arctanh): Removed extra definitions.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
60085
diff
changeset
|
319 (calc-cot arg)) |
60079
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
320 |
40785 | 321 (defun calc-arctan2 () |
322 (interactive) | |
323 (calc-slow-wrapper | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
324 (calc-enter-result 2 "atn2" (cons 'calcFunc-arctan2 (calc-top-list-n 2))))) |
40785 | 325 |
326 (defun calc-conj (arg) | |
327 (interactive "P") | |
328 (calc-wrapper | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
329 (calc-unary-op "conj" 'calcFunc-conj arg))) |
40785 | 330 |
331 (defun calc-imaginary () | |
332 (interactive) | |
333 (calc-slow-wrapper | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
334 (calc-pop-push-record 1 "i*" (math-imaginary (calc-top-n 1))))) |
40785 | 335 |
336 (defun calc-to-degrees (arg) | |
337 (interactive "P") | |
338 (calc-wrapper | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
339 (calc-unary-op ">deg" 'calcFunc-deg arg))) |
40785 | 340 |
341 (defun calc-to-radians (arg) | |
342 (interactive "P") | |
343 (calc-wrapper | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
344 (calc-unary-op ">rad" 'calcFunc-rad arg))) |
40785 | 345 |
346 | |
347 (defun calc-degrees-mode (arg) | |
348 (interactive "p") | |
349 (cond ((= arg 1) | |
350 (calc-wrapper | |
351 (calc-change-mode 'calc-angle-mode 'deg) | |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41044
diff
changeset
|
352 (message "Angles measured in degrees"))) |
40785 | 353 ((= arg 2) (calc-radians-mode)) |
354 ((= arg 3) (calc-hms-mode)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
355 (t (error "Prefix argument out of range")))) |
40785 | 356 |
357 (defun calc-radians-mode () | |
358 (interactive) | |
359 (calc-wrapper | |
360 (calc-change-mode 'calc-angle-mode 'rad) | |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41044
diff
changeset
|
361 (message "Angles measured in radians"))) |
40785 | 362 |
363 | |
364 ;;; Compute the integer square-root floor(sqrt(A)). A > 0. [I I] [Public] | |
365 ;;; This method takes advantage of the fact that Newton's method starting | |
366 ;;; with an overestimate always works, even using truncating integer division! | |
367 (defun math-isqrt (a) | |
368 (cond ((Math-zerop a) a) | |
369 ((not (math-natnump a)) | |
370 (math-reject-arg a 'natnump)) | |
371 ((integerp a) | |
372 (math-isqrt-small a)) | |
373 (t | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
374 (math-normalize (cons 'bigpos (cdr (math-isqrt-bignum (cdr a)))))))) |
40785 | 375 |
376 (defun calcFunc-isqrt (a) | |
377 (if (math-realp a) | |
378 (math-isqrt (math-floor a)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
379 (math-floor (math-sqrt a)))) |
40785 | 380 |
381 | |
42206 | 382 ;;; This returns (flag . result) where the flag is t if A is a perfect square. |
40785 | 383 (defun math-isqrt-bignum (a) ; [P.l L] |
384 (let ((len (length a))) | |
385 (if (= (% len 2) 0) | |
386 (let* ((top (nthcdr (- len 2) a))) | |
387 (math-isqrt-bignum-iter | |
388 a | |
81597
4894ac2fb62c
(math-scale-bignum-digit-size): Renamed from math-scale-bignum-3.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81549
diff
changeset
|
389 (math-scale-bignum-digit-size |
40785 | 390 (math-bignum-big |
391 (1+ (math-isqrt-small | |
81597
4894ac2fb62c
(math-scale-bignum-digit-size): Renamed from math-scale-bignum-3.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81549
diff
changeset
|
392 (+ (* (nth 1 top) math-bignum-digit-size) (car top))))) |
40785 | 393 (1- (/ len 2))))) |
394 (let* ((top (nth (1- len) a))) | |
395 (math-isqrt-bignum-iter | |
396 a | |
81597
4894ac2fb62c
(math-scale-bignum-digit-size): Renamed from math-scale-bignum-3.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81549
diff
changeset
|
397 (math-scale-bignum-digit-size |
40785 | 398 (list (1+ (math-isqrt-small top))) |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
399 (/ len 2))))))) |
40785 | 400 |
401 (defun math-isqrt-bignum-iter (a guess) ; [l L l] | |
402 (math-working "isqrt" (cons 'bigpos guess)) | |
403 (let* ((q (math-div-bignum a guess)) | |
404 (s (math-add-bignum (car q) guess)) | |
405 (g2 (math-div2-bignum s)) | |
406 (comp (math-compare-bignum g2 guess))) | |
407 (if (< comp 0) | |
408 (math-isqrt-bignum-iter a g2) | |
409 (cons (and (= comp 0) | |
410 (math-zerop-bignum (cdr q)) | |
411 (= (% (car s) 2) 0)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
412 guess)))) |
40785 | 413 |
414 (defun math-zerop-bignum (a) | |
415 (and (eq (car a) 0) | |
416 (progn | |
417 (while (eq (car (setq a (cdr a))) 0)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
418 (null a)))) |
40785 | 419 |
81597
4894ac2fb62c
(math-scale-bignum-digit-size): Renamed from math-scale-bignum-3.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81549
diff
changeset
|
420 (defun math-scale-bignum-digit-size (a n) ; [L L S] |
40785 | 421 (while (> n 0) |
422 (setq a (cons 0 a) | |
423 n (1- n))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
424 a) |
40785 | 425 |
426 (defun math-isqrt-small (a) ; A > 0. [S S] | |
81597
4894ac2fb62c
(math-scale-bignum-digit-size): Renamed from math-scale-bignum-3.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81549
diff
changeset
|
427 (let ((g (cond ((>= a 1000000) 10000) |
4894ac2fb62c
(math-scale-bignum-digit-size): Renamed from math-scale-bignum-3.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81549
diff
changeset
|
428 ((>= a 10000) 1000) |
40785 | 429 ((>= a 100) 100) |
430 (t 10))) | |
431 g2) | |
432 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) | |
433 (setq g g2)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
434 g)) |
40785 | 435 |
436 | |
437 | |
438 | |
439 ;;; Compute the square root of a number. | |
440 ;;; [T N] if possible, else [F N] if possible, else [C N]. [Public] | |
441 (defun math-sqrt (a) | |
442 (or | |
443 (and (Math-zerop a) a) | |
444 (and (math-known-nonposp a) | |
445 (math-imaginary (math-sqrt (math-neg a)))) | |
446 (and (integerp a) | |
447 (let ((sqrt (math-isqrt-small a))) | |
448 (if (= (* sqrt sqrt) a) | |
449 sqrt | |
450 (if calc-symbolic-mode | |
451 (list 'calcFunc-sqrt a) | |
452 (math-sqrt-float (math-float a) (math-float sqrt)))))) | |
453 (and (eq (car-safe a) 'bigpos) | |
454 (let* ((res (math-isqrt-bignum (cdr a))) | |
455 (sqrt (math-normalize (cons 'bigpos (cdr res))))) | |
456 (if (car res) | |
457 sqrt | |
458 (if calc-symbolic-mode | |
459 (list 'calcFunc-sqrt a) | |
460 (math-sqrt-float (math-float a) (math-float sqrt)))))) | |
461 (and (eq (car-safe a) 'frac) | |
462 (let* ((num-res (math-isqrt-bignum (cdr (Math-bignum-test (nth 1 a))))) | |
463 (num-sqrt (math-normalize (cons 'bigpos (cdr num-res)))) | |
464 (den-res (math-isqrt-bignum (cdr (Math-bignum-test (nth 2 a))))) | |
465 (den-sqrt (math-normalize (cons 'bigpos (cdr den-res))))) | |
466 (if (and (car num-res) (car den-res)) | |
467 (list 'frac num-sqrt den-sqrt) | |
468 (if calc-symbolic-mode | |
469 (if (or (car num-res) (car den-res)) | |
470 (math-div (if (car num-res) | |
471 num-sqrt (list 'calcFunc-sqrt (nth 1 a))) | |
472 (if (car den-res) | |
473 den-sqrt (list 'calcFunc-sqrt (nth 2 a)))) | |
474 (list 'calcFunc-sqrt a)) | |
475 (math-sqrt-float (math-float a) | |
476 (math-div (math-float num-sqrt) den-sqrt)))))) | |
477 (and (eq (car-safe a) 'float) | |
478 (if calc-symbolic-mode | |
479 (if (= (% (nth 2 a) 2) 0) | |
480 (let ((res (math-isqrt-bignum | |
481 (cdr (Math-bignum-test (nth 1 a)))))) | |
482 (if (car res) | |
483 (math-make-float (math-normalize | |
484 (cons 'bigpos (cdr res))) | |
485 (/ (nth 2 a) 2)) | |
486 (signal 'inexact-result nil))) | |
487 (signal 'inexact-result nil)) | |
488 (math-sqrt-float a))) | |
489 (and (eq (car-safe a) 'cplx) | |
490 (math-with-extra-prec 2 | |
491 (let* ((d (math-abs a)) | |
492 (imag (math-sqrt (math-mul (math-sub d (nth 1 a)) | |
493 '(float 5 -1))))) | |
494 (list 'cplx | |
495 (math-sqrt (math-mul (math-add d (nth 1 a)) '(float 5 -1))) | |
496 (if (math-negp (nth 2 a)) (math-neg imag) imag))))) | |
497 (and (eq (car-safe a) 'polar) | |
498 (list 'polar | |
499 (math-sqrt (nth 1 a)) | |
500 (math-mul (nth 2 a) '(float 5 -1)))) | |
501 (and (eq (car-safe a) 'sdev) | |
502 (let ((sqrt (math-sqrt (nth 1 a)))) | |
503 (math-make-sdev sqrt | |
504 (math-div (nth 2 a) (math-mul sqrt 2))))) | |
505 (and (eq (car-safe a) 'intv) | |
506 (not (math-negp (nth 2 a))) | |
507 (math-make-intv (nth 1 a) (math-sqrt (nth 2 a)) (math-sqrt (nth 3 a)))) | |
508 (and (eq (car-safe a) '*) | |
509 (or (math-known-nonnegp (nth 1 a)) | |
510 (math-known-nonnegp (nth 2 a))) | |
511 (math-mul (math-sqrt (nth 1 a)) (math-sqrt (nth 2 a)))) | |
512 (and (eq (car-safe a) '/) | |
513 (or (and (math-known-nonnegp (nth 2 a)) | |
514 (math-div (math-sqrt (nth 1 a)) (math-sqrt (nth 2 a)))) | |
515 (and (math-known-nonnegp (nth 1 a)) | |
516 (not (math-equal-int (nth 1 a) 1)) | |
517 (math-mul (math-sqrt (nth 1 a)) | |
518 (math-sqrt (math-div 1 (nth 2 a))))))) | |
519 (and (eq (car-safe a) '^) | |
520 (math-known-evenp (nth 2 a)) | |
521 (math-known-realp (nth 1 a)) | |
522 (math-abs (math-pow (nth 1 a) (math-div (nth 2 a) 2)))) | |
523 (let ((inf (math-infinitep a))) | |
524 (and inf | |
525 (math-mul (math-sqrt (math-infinite-dir a inf)) inf))) | |
526 (progn | |
527 (calc-record-why 'numberp a) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
528 (list 'calcFunc-sqrt a)))) |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41044
diff
changeset
|
529 (defalias 'calcFunc-sqrt 'math-sqrt) |
40785 | 530 |
531 (defun math-infinite-dir (a &optional inf) | |
532 (or inf (setq inf (math-infinitep a))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
533 (math-normalize (math-expr-subst a inf 1))) |
40785 | 534 |
535 (defun math-sqrt-float (a &optional guess) ; [F F F] | |
536 (if calc-symbolic-mode | |
537 (signal 'inexact-result nil) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
538 (math-with-extra-prec 1 (math-sqrt-raw a guess)))) |
40785 | 539 |
540 (defun math-sqrt-raw (a &optional guess) ; [F F F] | |
541 (if (not (Math-posp a)) | |
542 (math-sqrt a) | |
82238
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
543 (cond |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
544 ((math-use-emacs-fn 'sqrt a)) |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
545 (t |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
546 (if (null guess) |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
547 (let ((ldiff (- (math-numdigs (nth 1 a)) 6))) |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
548 (or (= (% (+ (nth 2 a) ldiff) 2) 0) (setq ldiff (1+ ldiff))) |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
549 (setq guess (math-make-float (math-isqrt-small |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
550 (math-scale-int (nth 1 a) (- ldiff))) |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
551 (/ (+ (nth 2 a) ldiff) 2))))) |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
552 (math-sqrt-float-iter a guess))))) |
40785 | 553 |
554 (defun math-sqrt-float-iter (a guess) ; [F F F] | |
555 (math-working "sqrt" guess) | |
556 (let ((g2 (math-mul-float (math-add-float guess (math-div-float a guess)) | |
557 '(float 5 -1)))) | |
558 (if (math-nearly-equal-float g2 guess) | |
559 g2 | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
560 (math-sqrt-float-iter a g2)))) |
40785 | 561 |
562 ;;; True if A and B differ only in the last digit of precision. [P F F] | |
563 (defun math-nearly-equal-float (a b) | |
564 (let ((ediff (- (nth 2 a) (nth 2 b)))) | |
565 (cond ((= ediff 0) ;; Expanded out for speed | |
566 (setq ediff (math-add (Math-integer-neg (nth 1 a)) (nth 1 b))) | |
567 (or (eq ediff 0) | |
568 (and (not (consp ediff)) | |
569 (< ediff 10) | |
570 (> ediff -10) | |
571 (= (math-numdigs (nth 1 a)) calc-internal-prec)))) | |
572 ((= ediff 1) | |
573 (setq ediff (math-add (Math-integer-neg (nth 1 b)) | |
574 (math-scale-int (nth 1 a) 1))) | |
575 (and (not (consp ediff)) | |
576 (< ediff 10) | |
577 (> ediff -10) | |
578 (= (math-numdigs (nth 1 b)) calc-internal-prec))) | |
579 ((= ediff -1) | |
580 (setq ediff (math-add (Math-integer-neg (nth 1 a)) | |
581 (math-scale-int (nth 1 b) 1))) | |
582 (and (not (consp ediff)) | |
583 (< ediff 10) | |
584 (> ediff -10) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
585 (= (math-numdigs (nth 1 a)) calc-internal-prec)))))) |
40785 | 586 |
587 (defun math-nearly-equal (a b) ; [P N N] [Public] | |
588 (setq a (math-float a)) | |
589 (setq b (math-float b)) | |
590 (if (eq (car a) 'polar) (setq a (math-complex a))) | |
591 (if (eq (car b) 'polar) (setq b (math-complex b))) | |
592 (if (eq (car a) 'cplx) | |
593 (if (eq (car b) 'cplx) | |
594 (and (or (math-nearly-equal-float (nth 1 a) (nth 1 b)) | |
595 (and (math-nearly-zerop-float (nth 1 a) (nth 2 a)) | |
596 (math-nearly-zerop-float (nth 1 b) (nth 2 b)))) | |
597 (or (math-nearly-equal-float (nth 2 a) (nth 2 b)) | |
598 (and (math-nearly-zerop-float (nth 2 a) (nth 1 a)) | |
599 (math-nearly-zerop-float (nth 2 b) (nth 1 b))))) | |
600 (and (math-nearly-equal-float (nth 1 a) b) | |
601 (math-nearly-zerop-float (nth 2 a) b))) | |
602 (if (eq (car b) 'cplx) | |
603 (and (math-nearly-equal-float a (nth 1 b)) | |
604 (math-nearly-zerop-float a (nth 2 b))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
605 (math-nearly-equal-float a b)))) |
40785 | 606 |
607 ;;; True if A is nearly zero compared to B. [P F F] | |
608 (defun math-nearly-zerop-float (a b) | |
609 (or (eq (nth 1 a) 0) | |
610 (<= (+ (math-numdigs (nth 1 a)) (nth 2 a)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
611 (1+ (- (+ (math-numdigs (nth 1 b)) (nth 2 b)) calc-internal-prec))))) |
40785 | 612 |
613 (defun math-nearly-zerop (a b) ; [P N R] [Public] | |
614 (setq a (math-float a)) | |
615 (setq b (math-float b)) | |
616 (if (eq (car a) 'cplx) | |
617 (and (math-nearly-zerop-float (nth 1 a) b) | |
618 (math-nearly-zerop-float (nth 2 a) b)) | |
619 (if (eq (car a) 'polar) | |
620 (math-nearly-zerop-float (nth 1 a) b) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
621 (math-nearly-zerop-float a b)))) |
40785 | 622 |
623 ;;; This implementation could be improved, accuracy-wise. | |
624 (defun math-hypot (a b) | |
625 (cond ((Math-zerop a) (math-abs b)) | |
626 ((Math-zerop b) (math-abs a)) | |
627 ((not (Math-scalarp a)) | |
628 (if (math-infinitep a) | |
629 (if (math-infinitep b) | |
630 (if (equal a b) | |
631 a | |
632 '(var nan var-nan)) | |
633 a) | |
634 (calc-record-why 'scalarp a) | |
635 (list 'calcFunc-hypot a b))) | |
636 ((not (Math-scalarp b)) | |
637 (if (math-infinitep b) | |
638 b | |
639 (calc-record-why 'scalarp b) | |
640 (list 'calcFunc-hypot a b))) | |
641 ((and (Math-numberp a) (Math-numberp b)) | |
642 (math-with-extra-prec 1 | |
643 (math-sqrt (math-add (calcFunc-abssqr a) (calcFunc-abssqr b))))) | |
644 ((eq (car-safe a) 'hms) | |
645 (if (eq (car-safe b) 'hms) ; this helps sdev's of hms forms | |
646 (math-to-hms (math-hypot (math-from-hms a 'deg) | |
647 (math-from-hms b 'deg))) | |
648 (math-to-hms (math-hypot (math-from-hms a 'deg) b)))) | |
649 ((eq (car-safe b) 'hms) | |
650 (math-to-hms (math-hypot a (math-from-hms b 'deg)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
651 (t nil))) |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41044
diff
changeset
|
652 (defalias 'calcFunc-hypot 'math-hypot) |
40785 | 653 |
654 (defun calcFunc-sqr (x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
655 (math-pow x 2)) |
40785 | 656 |
657 | |
658 | |
659 (defun math-nth-root (a n) | |
660 (cond ((= n 2) (math-sqrt a)) | |
661 ((Math-zerop a) a) | |
662 ((Math-negp a) nil) | |
663 ((Math-integerp a) | |
664 (let ((root (math-nth-root-integer a n))) | |
665 (if (car root) | |
666 (cdr root) | |
667 (and (not calc-symbolic-mode) | |
668 (math-nth-root-float (math-float a) n | |
669 (math-float (cdr root))))))) | |
670 ((eq (car-safe a) 'frac) | |
671 (let* ((num-root (math-nth-root-integer (nth 1 a) n)) | |
672 (den-root (math-nth-root-integer (nth 2 a) n))) | |
673 (if (and (car num-root) (car den-root)) | |
674 (list 'frac (cdr num-root) (cdr den-root)) | |
675 (and (not calc-symbolic-mode) | |
676 (math-nth-root-float | |
677 (math-float a) n | |
678 (math-div-float (math-float (cdr num-root)) | |
679 (math-float (cdr den-root)))))))) | |
680 ((eq (car-safe a) 'float) | |
681 (and (not calc-symbolic-mode) | |
682 (math-nth-root-float a n))) | |
683 ((eq (car-safe a) 'polar) | |
684 (let ((root (math-nth-root (nth 1 a) n))) | |
685 (and root (list 'polar root (math-div (nth 2 a) n))))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
686 (t nil))) |
40785 | 687 |
58475
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
688 ;; The variables math-nrf-n, math-nrf-nf and math-nrf-nfm1 are local |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
689 ;; to math-nth-root-float, but are used by math-nth-root-float-iter, |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
690 ;; which is called by math-nth-root-float. |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
691 (defvar math-nrf-n) |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
692 (defvar math-nrf-nf) |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
693 (defvar math-nrf-nfm1) |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
694 |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
695 (defun math-nth-root-float (a math-nrf-n &optional guess) |
40785 | 696 (math-inexact-result) |
697 (math-with-extra-prec 1 | |
58475
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
698 (let ((math-nrf-nf (math-float math-nrf-n)) |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
699 (math-nrf-nfm1 (math-float (1- math-nrf-n)))) |
40785 | 700 (math-nth-root-float-iter a (or guess |
701 (math-make-float | |
702 1 (/ (+ (math-numdigs (nth 1 a)) | |
703 (nth 2 a) | |
58475
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
704 (/ math-nrf-n 2)) |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
705 math-nrf-n))))))) |
40785 | 706 |
58475
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
707 (defun math-nth-root-float-iter (a guess) |
40785 | 708 (math-working "root" guess) |
58475
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
709 (let ((g2 (math-div-float (math-add-float (math-mul math-nrf-nfm1 guess) |
40785 | 710 (math-div-float |
58475
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
711 a (math-ipow guess (1- math-nrf-n)))) |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
712 math-nrf-nf))) |
40785 | 713 (if (math-nearly-equal-float g2 guess) |
714 g2 | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
715 (math-nth-root-float-iter a g2)))) |
40785 | 716 |
58475
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
717 ;; The variable math-nri-n is local to math-nth-root-integer, but |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
718 ;; is used by math-nth-root-int-iter, which is called by |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
719 ;; math-nth-root-int. |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
720 (defvar math-nri-n) |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
721 |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
722 (defun math-nth-root-integer (a math-nri-n &optional guess) ; [I I S] |
40785 | 723 (math-nth-root-int-iter a (or guess |
724 (math-scale-int 1 (/ (+ (math-numdigs a) | |
58475
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
725 (1- math-nri-n)) |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
726 math-nri-n))))) |
40785 | 727 |
58475
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
728 (defun math-nth-root-int-iter (a guess) |
40785 | 729 (math-working "root" guess) |
58475
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
730 (let* ((q (math-idivmod a (math-ipow guess (1- math-nri-n)))) |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
731 (s (math-add (car q) (math-mul (1- math-nri-n) guess))) |
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
732 (g2 (math-idivmod s math-nri-n))) |
40785 | 733 (if (Math-natnum-lessp (car g2) guess) |
734 (math-nth-root-int-iter a (car g2)) | |
735 (cons (and (equal (car g2) guess) | |
736 (eq (cdr q) 0) | |
737 (eq (cdr g2) 0)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
738 guess)))) |
40785 | 739 |
740 (defun calcFunc-nroot (x n) | |
741 (calcFunc-pow x (if (integerp n) | |
742 (math-make-frac 1 n) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
743 (math-div 1 n)))) |
40785 | 744 |
745 | |
746 | |
747 | |
748 ;;;; Transcendental functions. | |
749 | |
750 ;;; All of these functions are defined on the complex plane. | |
751 ;;; (Branch cuts, etc. follow Steele's Common Lisp book.) | |
752 | |
753 ;;; Most functions increase calc-internal-prec by 2 digits, then round | |
754 ;;; down afterward. "-raw" functions use the current precision, require | |
755 ;;; their arguments to be in float (or complex float) format, and always | |
756 ;;; work in radians (where applicable). | |
757 | |
758 (defun math-to-radians (a) ; [N N] | |
759 (cond ((eq (car-safe a) 'hms) | |
760 (math-from-hms a 'rad)) | |
761 ((memq calc-angle-mode '(deg hms)) | |
762 (math-mul a (math-pi-over-180))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
763 (t a))) |
40785 | 764 |
765 (defun math-from-radians (a) ; [N N] | |
766 (cond ((eq calc-angle-mode 'deg) | |
767 (if (math-constp a) | |
768 (math-div a (math-pi-over-180)) | |
769 (list 'calcFunc-deg a))) | |
770 ((eq calc-angle-mode 'hms) | |
771 (math-to-hms a 'rad)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
772 (t a))) |
40785 | 773 |
774 (defun math-to-radians-2 (a) ; [N N] | |
775 (cond ((eq (car-safe a) 'hms) | |
776 (math-from-hms a 'rad)) | |
777 ((memq calc-angle-mode '(deg hms)) | |
778 (if calc-symbolic-mode | |
779 (math-div (math-mul a '(var pi var-pi)) 180) | |
780 (math-mul a (math-pi-over-180)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
781 (t a))) |
40785 | 782 |
783 (defun math-from-radians-2 (a) ; [N N] | |
784 (cond ((memq calc-angle-mode '(deg hms)) | |
785 (if calc-symbolic-mode | |
786 (math-div (math-mul 180 a) '(var pi var-pi)) | |
787 (math-div a (math-pi-over-180)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
788 (t a))) |
40785 | 789 |
790 | |
791 | |
792 ;;; Sine, cosine, and tangent. | |
793 | |
794 (defun calcFunc-sin (x) ; [N N] [Public] | |
795 (cond ((and (integerp x) | |
796 (if (eq calc-angle-mode 'deg) | |
797 (= (% x 90) 0) | |
798 (= x 0))) | |
799 (aref [0 1 0 -1] (math-mod (/ x 90) 4))) | |
800 ((Math-scalarp x) | |
801 (math-with-extra-prec 2 | |
802 (math-sin-raw (math-to-radians (math-float x))))) | |
803 ((eq (car x) 'sdev) | |
804 (if (math-constp x) | |
805 (math-with-extra-prec 2 | |
806 (let* ((xx (math-to-radians (math-float (nth 1 x)))) | |
807 (xs (math-to-radians (math-float (nth 2 x)))) | |
808 (sc (math-sin-cos-raw xx))) | |
809 (math-make-sdev (car sc) (math-mul xs (cdr sc))))) | |
810 (math-make-sdev (calcFunc-sin (nth 1 x)) | |
811 (math-mul (nth 2 x) (calcFunc-cos (nth 1 x)))))) | |
812 ((and (eq (car x) 'intv) (math-intv-constp x)) | |
813 (calcFunc-cos (math-sub x (math-quarter-circle nil)))) | |
814 ((equal x '(var nan var-nan)) | |
815 x) | |
816 (t (calc-record-why 'scalarp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
817 (list 'calcFunc-sin x)))) |
40785 | 818 |
819 (defun calcFunc-cos (x) ; [N N] [Public] | |
820 (cond ((and (integerp x) | |
821 (if (eq calc-angle-mode 'deg) | |
822 (= (% x 90) 0) | |
823 (= x 0))) | |
824 (aref [1 0 -1 0] (math-mod (/ x 90) 4))) | |
825 ((Math-scalarp x) | |
826 (math-with-extra-prec 2 | |
827 (math-cos-raw (math-to-radians (math-float x))))) | |
828 ((eq (car x) 'sdev) | |
829 (if (math-constp x) | |
830 (math-with-extra-prec 2 | |
831 (let* ((xx (math-to-radians (math-float (nth 1 x)))) | |
832 (xs (math-to-radians (math-float (nth 2 x)))) | |
833 (sc (math-sin-cos-raw xx))) | |
834 (math-make-sdev (cdr sc) (math-mul xs (car sc))))) | |
835 (math-make-sdev (calcFunc-cos (nth 1 x)) | |
836 (math-mul (nth 2 x) (calcFunc-sin (nth 1 x)))))) | |
837 ((and (eq (car x) 'intv) (math-intv-constp x)) | |
838 (math-with-extra-prec 2 | |
839 (let* ((xx (math-to-radians (math-float x))) | |
840 (na (math-floor (math-div (nth 2 xx) (math-pi)))) | |
841 (nb (math-floor (math-div (nth 3 xx) (math-pi)))) | |
842 (span (math-sub nb na))) | |
843 (if (memq span '(0 1)) | |
844 (let ((int (math-sort-intv (nth 1 x) | |
845 (math-cos-raw (nth 2 xx)) | |
846 (math-cos-raw (nth 3 xx))))) | |
847 (if (eq span 1) | |
848 (if (math-evenp na) | |
849 (math-make-intv (logior (nth 1 x) 2) | |
850 -1 | |
851 (nth 3 int)) | |
852 (math-make-intv (logior (nth 1 x) 1) | |
853 (nth 2 int) | |
854 1)) | |
855 int)) | |
856 (list 'intv 3 -1 1))))) | |
857 ((equal x '(var nan var-nan)) | |
858 x) | |
859 (t (calc-record-why 'scalarp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
860 (list 'calcFunc-cos x)))) |
40785 | 861 |
862 (defun calcFunc-sincos (x) ; [V N] [Public] | |
863 (if (Math-scalarp x) | |
864 (math-with-extra-prec 2 | |
865 (let ((sc (math-sin-cos-raw (math-to-radians (math-float x))))) | |
866 (list 'vec (cdr sc) (car sc)))) ; the vector [cos, sin] | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
867 (list 'vec (calcFunc-sin x) (calcFunc-cos x)))) |
40785 | 868 |
869 (defun calcFunc-tan (x) ; [N N] [Public] | |
870 (cond ((and (integerp x) | |
871 (if (eq calc-angle-mode 'deg) | |
872 (= (% x 180) 0) | |
873 (= x 0))) | |
874 0) | |
875 ((Math-scalarp x) | |
876 (math-with-extra-prec 2 | |
877 (math-tan-raw (math-to-radians (math-float x))))) | |
878 ((eq (car x) 'sdev) | |
879 (if (math-constp x) | |
880 (math-with-extra-prec 2 | |
881 (let* ((xx (math-to-radians (math-float (nth 1 x)))) | |
882 (xs (math-to-radians (math-float (nth 2 x)))) | |
883 (sc (math-sin-cos-raw xx))) | |
884 (if (and (math-zerop (cdr sc)) (not calc-infinite-mode)) | |
885 (progn | |
886 (calc-record-why "*Division by zero") | |
887 (list 'calcFunc-tan x)) | |
888 (math-make-sdev (math-div-float (car sc) (cdr sc)) | |
889 (math-div-float xs (math-sqr (cdr sc))))))) | |
890 (math-make-sdev (calcFunc-tan (nth 1 x)) | |
891 (math-div (nth 2 x) | |
892 (math-sqr (calcFunc-cos (nth 1 x))))))) | |
893 ((and (eq (car x) 'intv) (math-intv-constp x)) | |
894 (or (math-with-extra-prec 2 | |
895 (let* ((xx (math-to-radians (math-float x))) | |
896 (na (math-floor (math-div (math-sub (nth 2 xx) | |
897 (math-pi-over-2)) | |
898 (math-pi)))) | |
899 (nb (math-floor (math-div (math-sub (nth 3 xx) | |
900 (math-pi-over-2)) | |
901 (math-pi))))) | |
902 (and (equal na nb) | |
903 (math-sort-intv (nth 1 x) | |
904 (math-tan-raw (nth 2 xx)) | |
905 (math-tan-raw (nth 3 xx)))))) | |
906 '(intv 3 (neg (var inf var-inf)) (var inf var-inf)))) | |
907 ((equal x '(var nan var-nan)) | |
908 x) | |
909 (t (calc-record-why 'scalarp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
910 (list 'calcFunc-tan x)))) |
40785 | 911 |
60079
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
912 (defun calcFunc-sec (x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
913 (cond ((and (integerp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
914 (eq calc-angle-mode 'deg) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
915 (= (% x 180) 0)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
916 (if (= (% x 360) 0) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
917 1 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
918 -1)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
919 ((and (integerp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
920 (eq calc-angle-mode 'rad) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
921 (= x 0)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
922 1) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
923 ((Math-scalarp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
924 (math-with-extra-prec 2 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
925 (math-sec-raw (math-to-radians (math-float x))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
926 ((eq (car x) 'sdev) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
927 (if (math-constp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
928 (math-with-extra-prec 2 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
929 (let* ((xx (math-to-radians (math-float (nth 1 x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
930 (xs (math-to-radians (math-float (nth 2 x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
931 (sc (math-sin-cos-raw xx))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
932 (if (and (math-zerop (cdr sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
933 (not calc-infinite-mode)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
934 (progn |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
935 (calc-record-why "*Division by zero") |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
936 (list 'calcFunc-sec x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
937 (math-make-sdev (math-div-float '(float 1 0) (cdr sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
938 (math-div-float |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
939 (math-mul xs (car sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
940 (math-sqr (cdr sc))))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
941 (math-make-sdev (calcFunc-sec (nth 1 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
942 (math-div |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
943 (math-mul (nth 2 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
944 (calcFunc-sin (nth 1 x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
945 (math-sqr (calcFunc-cos (nth 1 x))))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
946 ((and (eq (car x) 'intv) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
947 (math-intv-constp x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
948 (math-with-extra-prec 2 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
949 (let* ((xx (math-to-radians (math-float x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
950 (na (math-floor (math-div (math-sub (nth 2 xx) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
951 (math-pi-over-2)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
952 (math-pi)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
953 (nb (math-floor (math-div (math-sub (nth 3 xx) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
954 (math-pi-over-2)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
955 (math-pi)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
956 (naa (math-floor (math-div (nth 2 xx) (math-pi-over-2)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
957 (nbb (math-floor (math-div (nth 3 xx) (math-pi-over-2)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
958 (span (math-sub nbb naa))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
959 (if (not (equal na nb)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
960 '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
961 (let ((int (math-sort-intv (nth 1 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
962 (math-sec-raw (nth 2 xx)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
963 (math-sec-raw (nth 3 xx))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
964 (if (eq span 1) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
965 (if (math-evenp (math-div (math-add naa 1) 2)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
966 (math-make-intv (logior (nth 1 int) 2) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
967 1 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
968 (nth 3 int)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
969 (math-make-intv (logior (nth 1 int) 1) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
970 (nth 2 int) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
971 -1)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
972 int)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
973 ((equal x '(var nan var-nan)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
974 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
975 (t (calc-record-why 'scalarp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
976 (list 'calcFunc-sec x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
977 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
978 (defun calcFunc-csc (x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
979 (cond ((and (integerp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
980 (eq calc-angle-mode 'deg) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
981 (= (% (- x 90) 180) 0)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
982 (if (= (% (- x 90) 360) 0) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
983 1 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
984 -1)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
985 ((Math-scalarp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
986 (math-with-extra-prec 2 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
987 (math-csc-raw (math-to-radians (math-float x))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
988 ((eq (car x) 'sdev) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
989 (if (math-constp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
990 (math-with-extra-prec 2 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
991 (let* ((xx (math-to-radians (math-float (nth 1 x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
992 (xs (math-to-radians (math-float (nth 2 x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
993 (sc (math-sin-cos-raw xx))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
994 (if (and (math-zerop (car sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
995 (not calc-infinite-mode)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
996 (progn |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
997 (calc-record-why "*Division by zero") |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
998 (list 'calcFunc-csc x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
999 (math-make-sdev (math-div-float '(float 1 0) (car sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1000 (math-div-float |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1001 (math-mul xs (cdr sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1002 (math-sqr (car sc))))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1003 (math-make-sdev (calcFunc-csc (nth 1 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1004 (math-div |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1005 (math-mul (nth 2 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1006 (calcFunc-cos (nth 1 x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1007 (math-sqr (calcFunc-sin (nth 1 x))))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1008 ((and (eq (car x) 'intv) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1009 (math-intv-constp x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1010 (math-with-extra-prec 2 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1011 (let* ((xx (math-to-radians (math-float x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1012 (na (math-floor (math-div (nth 2 xx) (math-pi)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1013 (nb (math-floor (math-div (nth 3 xx) (math-pi)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1014 (naa (math-floor (math-div (nth 2 xx) (math-pi-over-2)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1015 (nbb (math-floor (math-div (nth 3 xx) (math-pi-over-2)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1016 (span (math-sub nbb naa))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1017 (if (not (equal na nb)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1018 '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1019 (let ((int (math-sort-intv (nth 1 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1020 (math-csc-raw (nth 2 xx)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1021 (math-csc-raw (nth 3 xx))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1022 (if (eq span 1) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1023 (if (math-evenp (math-div naa 2)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1024 (math-make-intv (logior (nth 1 int) 2) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1025 1 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1026 (nth 3 int)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1027 (math-make-intv (logior (nth 1 int) 1) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1028 (nth 2 int) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1029 -1)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1030 int)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1031 ((equal x '(var nan var-nan)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1032 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1033 (t (calc-record-why 'scalarp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1034 (list 'calcFunc-csc x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1035 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1036 (defun calcFunc-cot (x) ; [N N] [Public] |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1037 (cond ((and (integerp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1038 (if (eq calc-angle-mode 'deg) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1039 (= (% (- x 90) 180) 0) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1040 (= x 0))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1041 0) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1042 ((Math-scalarp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1043 (math-with-extra-prec 2 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1044 (math-cot-raw (math-to-radians (math-float x))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1045 ((eq (car x) 'sdev) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1046 (if (math-constp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1047 (math-with-extra-prec 2 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1048 (let* ((xx (math-to-radians (math-float (nth 1 x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1049 (xs (math-to-radians (math-float (nth 2 x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1050 (sc (math-sin-cos-raw xx))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1051 (if (and (math-zerop (car sc)) (not calc-infinite-mode)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1052 (progn |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1053 (calc-record-why "*Division by zero") |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1054 (list 'calcFunc-cot x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1055 (math-make-sdev (math-div-float (cdr sc) (car sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1056 (math-div-float xs (math-sqr (car sc))))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1057 (math-make-sdev (calcFunc-cot (nth 1 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1058 (math-div (nth 2 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1059 (math-sqr (calcFunc-sin (nth 1 x))))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1060 ((and (eq (car x) 'intv) (math-intv-constp x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1061 (or (math-with-extra-prec 2 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1062 (let* ((xx (math-to-radians (math-float x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1063 (na (math-floor (math-div (nth 2 xx) (math-pi)))) |
60164
697e2ba683cc
(calc-arctan, calc-tanh, calc-arctanh): Removed extra definitions.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
60085
diff
changeset
|
1064 (nb (math-floor (math-div (nth 3 xx) (math-pi))))) |
60079
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1065 (and (equal na nb) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1066 (math-sort-intv (nth 1 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1067 (math-cot-raw (nth 2 xx)) |
60164
697e2ba683cc
(calc-arctan, calc-tanh, calc-arctanh): Removed extra definitions.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
60085
diff
changeset
|
1068 (math-cot-raw (nth 3 xx)))))) |
60079
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1069 '(intv 3 (neg (var inf var-inf)) (var inf var-inf)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1070 ((equal x '(var nan var-nan)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1071 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1072 (t (calc-record-why 'scalarp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1073 (list 'calcFunc-cot x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1074 |
91997
17b9e01fbc76
(math-sin-raw): Add optional argument to keep track of
Jay Belanger <jay.p.belanger@gmail.com>
parents:
87649
diff
changeset
|
1075 (defun math-sin-raw (x &optional orgx) ; [N N] |
40785 | 1076 (cond ((eq (car x) 'cplx) |
1077 (let* ((expx (math-exp-raw (nth 2 x))) | |
1078 (expmx (math-div-float '(float 1 0) expx)) | |
1079 (sc (math-sin-cos-raw (nth 1 x)))) | |
1080 (list 'cplx | |
1081 (math-mul-float (car sc) | |
1082 (math-mul-float (math-add-float expx expmx) | |
1083 '(float 5 -1))) | |
1084 (math-mul-float (cdr sc) | |
1085 (math-mul-float (math-sub-float expx expmx) | |
1086 '(float 5 -1)))))) | |
1087 ((eq (car x) 'polar) | |
1088 (math-polar (math-sin-raw (math-complex x)))) | |
1089 ((Math-integer-negp (nth 1 x)) | |
91997
17b9e01fbc76
(math-sin-raw): Add optional argument to keep track of
Jay Belanger <jay.p.belanger@gmail.com>
parents:
87649
diff
changeset
|
1090 (math-neg-float (math-sin-raw (math-neg-float x) (if orgx orgx x)))) |
40785 | 1091 ((math-lessp-float '(float 7 0) x) ; avoid inf loops due to roundoff |
91997
17b9e01fbc76
(math-sin-raw): Add optional argument to keep track of
Jay Belanger <jay.p.belanger@gmail.com>
parents:
87649
diff
changeset
|
1092 (math-sin-raw (math-mod x (math-two-pi)) (if orgx orgx x))) |
17b9e01fbc76
(math-sin-raw): Add optional argument to keep track of
Jay Belanger <jay.p.belanger@gmail.com>
parents:
87649
diff
changeset
|
1093 (t (math-sin-raw-2 x (if orgx orgx x))))) |
40785 | 1094 |
1095 (defun math-cos-raw (x) ; [N N] | |
1096 (if (eq (car-safe x) 'polar) | |
1097 (math-polar (math-cos-raw (math-complex x))) | |
91997
17b9e01fbc76
(math-sin-raw): Add optional argument to keep track of
Jay Belanger <jay.p.belanger@gmail.com>
parents:
87649
diff
changeset
|
1098 (math-sin-raw (math-sub (math-pi-over-2) x) x))) |
40785 | 1099 |
60079
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1100 (defun math-sec-raw (x) ; [N N] |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1101 (cond ((eq (car x) 'cplx) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1102 (let* ((x (math-mul x '(float 1 0))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1103 (expx (math-exp-raw (nth 2 x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1104 (expmx (math-div-float '(float 1 0) expx)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1105 (sh (math-mul-float (math-sub-float expx expmx) '(float 5 -1))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1106 (ch (math-mul-float (math-add-float expx expmx) '(float 5 -1))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1107 (sc (math-sin-cos-raw (nth 1 x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1108 (d (math-add-float |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1109 (math-mul-float (math-sqr (car sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1110 (math-sqr sh)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1111 (math-mul-float (math-sqr (cdr sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1112 (math-sqr ch))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1113 (and (not (eq (nth 1 d) 0)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1114 (list 'cplx |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1115 (math-div-float (math-mul-float (cdr sc) ch) d) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1116 (math-div-float (math-mul-float (car sc) sh) d))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1117 ((eq (car x) 'polar) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1118 (math-polar (math-sec-raw (math-complex x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1119 (t |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1120 (let ((cs (math-cos-raw x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1121 (if (eq cs 0) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1122 (math-div 1 0) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1123 (math-div-float '(float 1 0) cs)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1124 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1125 (defun math-csc-raw (x) ; [N N] |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1126 (cond ((eq (car x) 'cplx) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1127 (let* ((x (math-mul x '(float 1 0))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1128 (expx (math-exp-raw (nth 2 x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1129 (expmx (math-div-float '(float 1 0) expx)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1130 (sh (math-mul-float (math-sub-float expx expmx) '(float 5 -1))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1131 (ch (math-mul-float (math-add-float expx expmx) '(float 5 -1))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1132 (sc (math-sin-cos-raw (nth 1 x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1133 (d (math-add-float |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1134 (math-mul-float (math-sqr (car sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1135 (math-sqr ch)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1136 (math-mul-float (math-sqr (cdr sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1137 (math-sqr sh))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1138 (and (not (eq (nth 1 d) 0)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1139 (list 'cplx |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1140 (math-div-float (math-mul-float (car sc) ch) d) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1141 (math-div-float (math-mul-float (cdr sc) sh) d))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1142 ((eq (car x) 'polar) |
60085
f91c9a606821
(math-csc-raw): Fix typo.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
60079
diff
changeset
|
1143 (math-polar (math-csc-raw (math-complex x)))) |
60079
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1144 (t |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1145 (let ((sn (math-sin-raw x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1146 (if (eq sn 0) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1147 (math-div 1 0) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1148 (math-div-float '(float 1 0) sn)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1149 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1150 (defun math-cot-raw (x) ; [N N] |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1151 (cond ((eq (car x) 'cplx) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1152 (let* ((x (math-mul x '(float 1 0))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1153 (expx (math-exp-raw (nth 2 x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1154 (expmx (math-div-float '(float 1 0) expx)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1155 (sh (math-mul-float (math-sub-float expx expmx) '(float 5 -1))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1156 (ch (math-mul-float (math-add-float expx expmx) '(float 5 -1))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1157 (sc (math-sin-cos-raw (nth 1 x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1158 (d (math-add-float |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1159 (math-sqr (car sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1160 (math-sqr sh)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1161 (and (not (eq (nth 1 d) 0)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1162 (list 'cplx |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1163 (math-div-float |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1164 (math-mul-float (car sc) (cdr sc)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1165 d) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1166 (math-neg |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1167 (math-div-float |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1168 (math-mul-float sh ch) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1169 d)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1170 ((eq (car x) 'polar) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1171 (math-polar (math-cot-raw (math-complex x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1172 (t |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1173 (let ((sc (math-sin-cos-raw x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1174 (if (eq (nth 1 (car sc)) 0) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1175 (math-div (cdr sc) 0) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1176 (math-div-float (cdr sc) (car sc))))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1177 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1178 |
40785 | 1179 ;;; This could use a smarter method: Reduce x as in math-sin-raw, then |
1180 ;;; compute either sin(x) or cos(x), whichever is smaller, and compute | |
1181 ;;; the other using the identity sin(x)^2 + cos(x)^2 = 1. | |
1182 (defun math-sin-cos-raw (x) ; [F.F F] (result is (sin x . cos x)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1183 (cons (math-sin-raw x) (math-cos-raw x))) |
40785 | 1184 |
1185 (defun math-tan-raw (x) ; [N N] | |
1186 (cond ((eq (car x) 'cplx) | |
1187 (let* ((x (math-mul x '(float 2 0))) | |
1188 (expx (math-exp-raw (nth 2 x))) | |
1189 (expmx (math-div-float '(float 1 0) expx)) | |
1190 (sc (math-sin-cos-raw (nth 1 x))) | |
1191 (d (math-add-float (cdr sc) | |
1192 (math-mul-float (math-add-float expx expmx) | |
1193 '(float 5 -1))))) | |
1194 (and (not (eq (nth 1 d) 0)) | |
1195 (list 'cplx | |
1196 (math-div-float (car sc) d) | |
1197 (math-div-float (math-mul-float (math-sub-float expx | |
1198 expmx) | |
1199 '(float 5 -1)) d))))) | |
1200 ((eq (car x) 'polar) | |
1201 (math-polar (math-tan-raw (math-complex x)))) | |
1202 (t | |
1203 (let ((sc (math-sin-cos-raw x))) | |
1204 (if (eq (nth 1 (cdr sc)) 0) | |
1205 (math-div (car sc) 0) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1206 (math-div-float (car sc) (cdr sc))))))) |
40785 | 1207 |
1208 (defun math-sin-raw-2 (x orgx) ; This avoids poss of inf recursion. [F F] | |
1209 (let ((xmpo2 (math-sub-float (math-pi-over-2) x))) | |
1210 (cond ((Math-integer-negp (nth 1 xmpo2)) | |
1211 (math-neg-float (math-sin-raw-2 (math-sub-float x (math-pi)) | |
1212 orgx))) | |
1213 ((math-lessp-float (math-pi-over-4) x) | |
1214 (math-cos-raw-2 xmpo2 orgx)) | |
1215 ((math-lessp-float x (math-neg (math-pi-over-4))) | |
1216 (math-neg (math-cos-raw-2 (math-add (math-pi-over-2) x) orgx))) | |
91997
17b9e01fbc76
(math-sin-raw): Add optional argument to keep track of
Jay Belanger <jay.p.belanger@gmail.com>
parents:
87649
diff
changeset
|
1217 ((math-with-extra-prec -1 (math-nearly-zerop-float x orgx)) |
17b9e01fbc76
(math-sin-raw): Add optional argument to keep track of
Jay Belanger <jay.p.belanger@gmail.com>
parents:
87649
diff
changeset
|
1218 '(float 0 0)) |
82238
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
1219 ((math-use-emacs-fn 'sin x)) |
40785 | 1220 (calc-symbolic-mode (signal 'inexact-result nil)) |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1221 (t (math-sin-series x 6 4 x (math-neg-float (math-sqr-float x))))))) |
40785 | 1222 |
1223 (defun math-cos-raw-2 (x orgx) ; [F F] | |
91997
17b9e01fbc76
(math-sin-raw): Add optional argument to keep track of
Jay Belanger <jay.p.belanger@gmail.com>
parents:
87649
diff
changeset
|
1224 (cond ((math-with-extra-prec -1 (math-nearly-zerop-float x orgx)) |
17b9e01fbc76
(math-sin-raw): Add optional argument to keep track of
Jay Belanger <jay.p.belanger@gmail.com>
parents:
87649
diff
changeset
|
1225 '(float 1 0)) |
82238
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
1226 ((math-use-emacs-fn 'cos x)) |
40785 | 1227 (calc-symbolic-mode (signal 'inexact-result nil)) |
1228 (t (let ((xnegsqr (math-neg-float (math-sqr-float x)))) | |
1229 (math-sin-series | |
1230 (math-add-float '(float 1 0) | |
1231 (math-mul-float xnegsqr '(float 5 -1))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1232 24 5 xnegsqr xnegsqr))))) |
40785 | 1233 |
1234 (defun math-sin-series (sum nfac n x xnegsqr) | |
1235 (math-working "sin" sum) | |
1236 (let* ((nextx (math-mul-float x xnegsqr)) | |
1237 (nextsum (math-add-float sum (math-div-float nextx | |
1238 (math-float nfac))))) | |
1239 (if (math-nearly-equal-float sum nextsum) | |
1240 sum | |
1241 (math-sin-series nextsum (math-mul nfac (* n (1+ n))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1242 (+ n 2) nextx xnegsqr)))) |
40785 | 1243 |
1244 | |
1245 ;;; Inverse sine, cosine, tangent. | |
1246 | |
1247 (defun calcFunc-arcsin (x) ; [N N] [Public] | |
1248 (cond ((eq x 0) 0) | |
1249 ((and (eq x 1) (eq calc-angle-mode 'deg)) 90) | |
1250 ((and (eq x -1) (eq calc-angle-mode 'deg)) -90) | |
1251 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1252 ((Math-numberp x) | |
1253 (math-with-extra-prec 2 | |
1254 (math-from-radians (math-arcsin-raw (math-float x))))) | |
1255 ((eq (car x) 'sdev) | |
1256 (math-make-sdev (calcFunc-arcsin (nth 1 x)) | |
1257 (math-from-radians | |
1258 (math-div (nth 2 x) | |
1259 (math-sqrt | |
1260 (math-sub 1 (math-sqr (nth 1 x)))))))) | |
1261 ((eq (car x) 'intv) | |
1262 (math-sort-intv (nth 1 x) | |
1263 (calcFunc-arcsin (nth 2 x)) | |
1264 (calcFunc-arcsin (nth 3 x)))) | |
1265 ((equal x '(var nan var-nan)) | |
1266 x) | |
1267 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1268 (list 'calcFunc-arcsin x)))) |
40785 | 1269 |
1270 (defun calcFunc-arccos (x) ; [N N] [Public] | |
1271 (cond ((eq x 1) 0) | |
1272 ((and (eq x 0) (eq calc-angle-mode 'deg)) 90) | |
1273 ((and (eq x -1) (eq calc-angle-mode 'deg)) 180) | |
1274 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1275 ((Math-numberp x) | |
1276 (math-with-extra-prec 2 | |
1277 (math-from-radians (math-arccos-raw (math-float x))))) | |
1278 ((eq (car x) 'sdev) | |
1279 (math-make-sdev (calcFunc-arccos (nth 1 x)) | |
1280 (math-from-radians | |
1281 (math-div (nth 2 x) | |
1282 (math-sqrt | |
1283 (math-sub 1 (math-sqr (nth 1 x)))))))) | |
1284 ((eq (car x) 'intv) | |
1285 (math-sort-intv (nth 1 x) | |
1286 (calcFunc-arccos (nth 2 x)) | |
1287 (calcFunc-arccos (nth 3 x)))) | |
1288 ((equal x '(var nan var-nan)) | |
1289 x) | |
1290 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1291 (list 'calcFunc-arccos x)))) |
40785 | 1292 |
1293 (defun calcFunc-arctan (x) ; [N N] [Public] | |
1294 (cond ((eq x 0) 0) | |
1295 ((and (eq x 1) (eq calc-angle-mode 'deg)) 45) | |
1296 ((and (eq x -1) (eq calc-angle-mode 'deg)) -45) | |
1297 ((Math-numberp x) | |
1298 (math-with-extra-prec 2 | |
1299 (math-from-radians (math-arctan-raw (math-float x))))) | |
1300 ((eq (car x) 'sdev) | |
1301 (math-make-sdev (calcFunc-arctan (nth 1 x)) | |
1302 (math-from-radians | |
1303 (math-div (nth 2 x) | |
1304 (math-add 1 (math-sqr (nth 1 x))))))) | |
1305 ((eq (car x) 'intv) | |
1306 (math-sort-intv (nth 1 x) | |
1307 (calcFunc-arctan (nth 2 x)) | |
1308 (calcFunc-arctan (nth 3 x)))) | |
1309 ((equal x '(var inf var-inf)) | |
1310 (math-quarter-circle t)) | |
1311 ((equal x '(neg (var inf var-inf))) | |
1312 (math-neg (math-quarter-circle t))) | |
1313 ((equal x '(var nan var-nan)) | |
1314 x) | |
1315 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1316 (list 'calcFunc-arctan x)))) |
40785 | 1317 |
1318 (defun math-arcsin-raw (x) ; [N N] | |
1319 (let ((a (math-sqrt-raw (math-sub '(float 1 0) (math-sqr x))))) | |
1320 (if (or (memq (car x) '(cplx polar)) | |
1321 (memq (car a) '(cplx polar))) | |
1322 (math-with-extra-prec 2 ; use extra precision for difficult case | |
1323 (math-mul '(cplx 0 -1) | |
1324 (math-ln-raw (math-add (math-mul '(cplx 0 1) x) a)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1325 (math-arctan2-raw x a)))) |
40785 | 1326 |
1327 (defun math-arccos-raw (x) ; [N N] | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1328 (math-sub (math-pi-over-2) (math-arcsin-raw x))) |
40785 | 1329 |
1330 (defun math-arctan-raw (x) ; [N N] | |
1331 (cond ((memq (car x) '(cplx polar)) | |
1332 (math-with-extra-prec 2 ; extra-extra | |
1333 (math-div (math-sub | |
1334 (math-ln-raw (math-add 1 (math-mul '(cplx 0 1) x))) | |
1335 (math-ln-raw (math-add 1 (math-mul '(cplx 0 -1) x)))) | |
1336 '(cplx 0 2)))) | |
1337 ((Math-integer-negp (nth 1 x)) | |
1338 (math-neg-float (math-arctan-raw (math-neg-float x)))) | |
1339 ((math-zerop x) x) | |
82238
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
1340 ((math-use-emacs-fn 'atan x)) |
40785 | 1341 (calc-symbolic-mode (signal 'inexact-result nil)) |
1342 ((math-equal-int x 1) (math-pi-over-4)) | |
1343 ((math-equal-int x -1) (math-neg (math-pi-over-4))) | |
1344 ((math-lessp-float '(float 414214 -6) x) ; if x > sqrt(2) - 1, reduce | |
1345 (if (math-lessp-float '(float 1 0) x) | |
1346 (math-sub-float (math-mul-float (math-pi) '(float 5 -1)) | |
1347 (math-arctan-raw (math-div-float '(float 1 0) x))) | |
1348 (math-sub-float (math-mul-float (math-pi) '(float 25 -2)) | |
1349 (math-arctan-raw (math-div-float | |
1350 (math-sub-float '(float 1 0) x) | |
1351 (math-add-float '(float 1 0) | |
1352 x)))))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1353 (t (math-arctan-series x 3 x (math-neg-float (math-sqr-float x)))))) |
40785 | 1354 |
1355 (defun math-arctan-series (sum n x xnegsqr) | |
1356 (math-working "arctan" sum) | |
1357 (let* ((nextx (math-mul-float x xnegsqr)) | |
1358 (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) | |
1359 (if (math-nearly-equal-float sum nextsum) | |
1360 sum | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1361 (math-arctan-series nextsum (+ n 2) nextx xnegsqr)))) |
40785 | 1362 |
1363 (defun calcFunc-arctan2 (y x) ; [F R R] [Public] | |
1364 (if (Math-anglep y) | |
1365 (if (Math-anglep x) | |
1366 (math-with-extra-prec 2 | |
1367 (math-from-radians (math-arctan2-raw (math-float y) | |
1368 (math-float x)))) | |
1369 (calc-record-why 'anglep x) | |
1370 (list 'calcFunc-arctan2 y x)) | |
1371 (if (and (or (math-infinitep x) (math-anglep x)) | |
1372 (or (math-infinitep y) (math-anglep y))) | |
1373 (progn | |
1374 (if (math-posp x) | |
1375 (setq x 1) | |
1376 (if (math-negp x) | |
1377 (setq x -1) | |
1378 (or (math-zerop x) | |
1379 (setq x nil)))) | |
1380 (if (math-posp y) | |
1381 (setq y 1) | |
1382 (if (math-negp y) | |
1383 (setq y -1) | |
1384 (or (math-zerop y) | |
1385 (setq y nil)))) | |
1386 (if (and y x) | |
1387 (calcFunc-arctan2 y x) | |
1388 '(var nan var-nan))) | |
1389 (calc-record-why 'anglep y) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1390 (list 'calcFunc-arctan2 y x)))) |
40785 | 1391 |
1392 (defun math-arctan2-raw (y x) ; [F R R] | |
1393 (cond ((math-zerop y) | |
1394 (if (math-negp x) (math-pi) | |
1395 (if (or (math-floatp x) (math-floatp y)) '(float 0 0) 0))) | |
1396 ((math-zerop x) | |
1397 (if (math-posp y) | |
1398 (math-pi-over-2) | |
1399 (math-neg (math-pi-over-2)))) | |
1400 ((math-posp x) | |
1401 (math-arctan-raw (math-div-float y x))) | |
1402 ((math-posp y) | |
1403 (math-add-float (math-arctan-raw (math-div-float y x)) | |
1404 (math-pi))) | |
1405 (t | |
1406 (math-sub-float (math-arctan-raw (math-div-float y x)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1407 (math-pi))))) |
40785 | 1408 |
1409 (defun calcFunc-arcsincos (x) ; [V N] [Public] | |
1410 (if (and (Math-vectorp x) | |
1411 (= (length x) 3)) | |
1412 (calcFunc-arctan2 (nth 2 x) (nth 1 x)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1413 (math-reject-arg x "*Two-element vector expected"))) |
40785 | 1414 |
1415 | |
1416 | |
1417 ;;; Exponential function. | |
1418 | |
1419 (defun calcFunc-exp (x) ; [N N] [Public] | |
1420 (cond ((eq x 0) 1) | |
1421 ((and (memq x '(1 -1)) calc-symbolic-mode) | |
1422 (if (eq x 1) '(var e var-e) (math-div 1 '(var e var-e)))) | |
1423 ((Math-numberp x) | |
1424 (math-with-extra-prec 2 (math-exp-raw (math-float x)))) | |
1425 ((eq (car-safe x) 'sdev) | |
1426 (let ((ex (calcFunc-exp (nth 1 x)))) | |
1427 (math-make-sdev ex (math-mul (nth 2 x) ex)))) | |
1428 ((eq (car-safe x) 'intv) | |
1429 (math-make-intv (nth 1 x) (calcFunc-exp (nth 2 x)) | |
1430 (calcFunc-exp (nth 3 x)))) | |
1431 ((equal x '(var inf var-inf)) | |
1432 x) | |
1433 ((equal x '(neg (var inf var-inf))) | |
1434 0) | |
1435 ((equal x '(var nan var-nan)) | |
1436 x) | |
1437 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1438 (list 'calcFunc-exp x)))) |
40785 | 1439 |
1440 (defun calcFunc-expm1 (x) ; [N N] [Public] | |
1441 (cond ((eq x 0) 0) | |
1442 ((math-zerop x) '(float 0 0)) | |
1443 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1444 ((Math-numberp x) | |
1445 (math-with-extra-prec 2 | |
1446 (let ((x (math-float x))) | |
1447 (if (and (eq (car x) 'float) | |
1448 (math-lessp-float x '(float 1 0)) | |
1449 (math-lessp-float '(float -1 0) x)) | |
1450 (math-exp-minus-1-raw x) | |
1451 (math-add (math-exp-raw x) -1))))) | |
1452 ((eq (car-safe x) 'sdev) | |
1453 (if (math-constp x) | |
1454 (let ((ex (calcFunc-expm1 (nth 1 x)))) | |
1455 (math-make-sdev ex (math-mul (nth 2 x) (math-add ex 1)))) | |
1456 (math-make-sdev (calcFunc-expm1 (nth 1 x)) | |
1457 (math-mul (nth 2 x) (calcFunc-exp (nth 1 x)))))) | |
1458 ((eq (car-safe x) 'intv) | |
1459 (math-make-intv (nth 1 x) | |
1460 (calcFunc-expm1 (nth 2 x)) | |
1461 (calcFunc-expm1 (nth 3 x)))) | |
1462 ((equal x '(var inf var-inf)) | |
1463 x) | |
1464 ((equal x '(neg (var inf var-inf))) | |
1465 -1) | |
1466 ((equal x '(var nan var-nan)) | |
1467 x) | |
1468 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1469 (list 'calcFunc-expm1 x)))) |
40785 | 1470 |
1471 (defun calcFunc-exp10 (x) ; [N N] [Public] | |
1472 (if (eq x 0) | |
1473 1 | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1474 (math-pow '(float 1 1) x))) |
40785 | 1475 |
1476 (defun math-exp-raw (x) ; [N N] | |
1477 (cond ((math-zerop x) '(float 1 0)) | |
1478 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1479 ((eq (car x) 'cplx) | |
1480 (let ((expx (math-exp-raw (nth 1 x))) | |
1481 (sc (math-sin-cos-raw (nth 2 x)))) | |
1482 (list 'cplx | |
1483 (math-mul-float expx (cdr sc)) | |
1484 (math-mul-float expx (car sc))))) | |
1485 ((eq (car x) 'polar) | |
1486 (let ((xc (math-complex x))) | |
1487 (list 'polar | |
1488 (math-exp-raw (nth 1 xc)) | |
1489 (math-from-radians (nth 2 xc))))) | |
82015
0795e1e56274
(math-emacs-precision, math-largest-emacs-expt)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81746
diff
changeset
|
1490 ((math-use-emacs-fn 'exp x)) |
40785 | 1491 ((or (math-lessp-float '(float 5 -1) x) |
1492 (math-lessp-float x '(float -5 -1))) | |
1493 (if (math-lessp-float '(float 921035 1) x) | |
1494 (math-overflow) | |
1495 (if (math-lessp-float x '(float -921035 1)) | |
1496 (math-underflow))) | |
1497 (let* ((two-x (math-mul-float x '(float 2 0))) | |
1498 (hint (math-scale-int (nth 1 two-x) (nth 2 two-x))) | |
1499 (hfrac (math-sub-float x (math-mul-float (math-float hint) | |
1500 '(float 5 -1))))) | |
1501 (math-mul-float (math-ipow (math-sqrt-e) hint) | |
1502 (math-add-float '(float 1 0) | |
1503 (math-exp-minus-1-raw hfrac))))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1504 (t (math-add-float '(float 1 0) (math-exp-minus-1-raw x))))) |
40785 | 1505 |
1506 (defun math-exp-minus-1-raw (x) ; [F F] | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1507 (math-exp-series x 2 3 x x)) |
40785 | 1508 |
1509 (defun math-exp-series (sum nfac n xpow x) | |
1510 (math-working "exp" sum) | |
1511 (let* ((nextx (math-mul-float xpow x)) | |
1512 (nextsum (math-add-float sum (math-div-float nextx | |
1513 (math-float nfac))))) | |
1514 (if (math-nearly-equal-float sum nextsum) | |
1515 sum | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1516 (math-exp-series nextsum (math-mul nfac n) (1+ n) nextx x)))) |
40785 | 1517 |
1518 | |
1519 | |
1520 ;;; Logarithms. | |
1521 | |
1522 (defun calcFunc-ln (x) ; [N N] [Public] | |
1523 (cond ((math-zerop x) | |
1524 (if calc-infinite-mode | |
1525 '(neg (var inf var-inf)) | |
1526 (math-reject-arg x "*Logarithm of zero"))) | |
1527 ((eq x 1) 0) | |
1528 ((Math-numberp x) | |
1529 (math-with-extra-prec 2 (math-ln-raw (math-float x)))) | |
1530 ((eq (car-safe x) 'sdev) | |
1531 (math-make-sdev (calcFunc-ln (nth 1 x)) | |
1532 (math-div (nth 2 x) (nth 1 x)))) | |
1533 ((and (eq (car-safe x) 'intv) (or (Math-posp (nth 2 x)) | |
1534 (Math-zerop (nth 2 x)) | |
1535 (not (math-intv-constp x)))) | |
1536 (let ((calc-infinite-mode t)) | |
1537 (math-make-intv (nth 1 x) (calcFunc-ln (nth 2 x)) | |
1538 (calcFunc-ln (nth 3 x))))) | |
1539 ((equal x '(var e var-e)) | |
1540 1) | |
1541 ((and (eq (car-safe x) '^) | |
1542 (equal (nth 1 x) '(var e var-e)) | |
1543 (math-known-realp (nth 2 x))) | |
1544 (nth 2 x)) | |
1545 ((math-infinitep x) | |
1546 (if (equal x '(var nan var-nan)) | |
1547 x | |
1548 '(var inf var-inf))) | |
1549 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1550 (list 'calcFunc-ln x)))) |
40785 | 1551 |
1552 (defun calcFunc-log10 (x) ; [N N] [Public] | |
1553 (cond ((math-equal-int x 1) | |
1554 (if (math-floatp x) '(float 0 0) 0)) | |
1555 ((and (Math-integerp x) | |
1556 (math-posp x) | |
1557 (let ((res (math-integer-log x 10))) | |
1558 (and (car res) | |
1559 (setq x (cdr res))))) | |
1560 x) | |
1561 ((and (eq (car-safe x) 'frac) | |
1562 (eq (nth 1 x) 1) | |
1563 (let ((res (math-integer-log (nth 2 x) 10))) | |
1564 (and (car res) | |
1565 (setq x (- (cdr res)))))) | |
1566 x) | |
1567 ((math-zerop x) | |
1568 (if calc-infinite-mode | |
1569 '(neg (var inf var-inf)) | |
1570 (math-reject-arg x "*Logarithm of zero"))) | |
1571 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1572 ((Math-numberp x) | |
1573 (math-with-extra-prec 2 | |
1574 (let ((xf (math-float x))) | |
1575 (if (eq (nth 1 xf) 0) | |
1576 (math-reject-arg x "*Logarithm of zero")) | |
1577 (if (Math-integer-posp (nth 1 xf)) | |
1578 (if (eq (nth 1 xf) 1) ; log10(1*10^n) = n | |
1579 (math-float (nth 2 xf)) | |
1580 (let ((xdigs (1- (math-numdigs (nth 1 xf))))) | |
1581 (math-add-float | |
1582 (math-div-float (math-ln-raw-2 | |
1583 (list 'float (nth 1 xf) (- xdigs))) | |
1584 (math-ln-10)) | |
1585 (math-float (+ (nth 2 xf) xdigs))))) | |
1586 (math-div (calcFunc-ln xf) (math-ln-10)))))) | |
1587 ((eq (car-safe x) 'sdev) | |
1588 (math-make-sdev (calcFunc-log10 (nth 1 x)) | |
1589 (math-div (nth 2 x) | |
1590 (math-mul (nth 1 x) (math-ln-10))))) | |
1591 ((and (eq (car-safe x) 'intv) (or (Math-posp (nth 2 x)) | |
1592 (not (math-intv-constp x)))) | |
1593 (math-make-intv (nth 1 x) | |
1594 (calcFunc-log10 (nth 2 x)) | |
1595 (calcFunc-log10 (nth 3 x)))) | |
1596 ((math-infinitep x) | |
1597 (if (equal x '(var nan var-nan)) | |
1598 x | |
1599 '(var inf var-inf))) | |
1600 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1601 (list 'calcFunc-log10 x)))) |
40785 | 1602 |
1603 (defun calcFunc-log (x &optional b) ; [N N N] [Public] | |
1604 (cond ((or (null b) (equal b '(var e var-e))) | |
1605 (math-normalize (list 'calcFunc-ln x))) | |
1606 ((or (eq b 10) (equal b '(float 1 1))) | |
1607 (math-normalize (list 'calcFunc-log10 x))) | |
1608 ((math-zerop x) | |
1609 (if calc-infinite-mode | |
1610 (math-div (calcFunc-ln x) (calcFunc-ln b)) | |
1611 (math-reject-arg x "*Logarithm of zero"))) | |
1612 ((math-zerop b) | |
1613 (if calc-infinite-mode | |
1614 (math-div (calcFunc-ln x) (calcFunc-ln b)) | |
1615 (math-reject-arg b "*Logarithm of zero"))) | |
1616 ((math-equal-int b 1) | |
1617 (if calc-infinite-mode | |
1618 (math-div (calcFunc-ln x) 0) | |
1619 (math-reject-arg b "*Logarithm base one"))) | |
1620 ((math-equal-int x 1) | |
58475
647b2f6dac36
(math-nrf-n, math-nrf-nf, math-nrf-nfm1): New variables.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
1621 (if (math-floatp b) '(float 0 0) 0)) |
40785 | 1622 ((and (Math-ratp x) (Math-ratp b) |
1623 (math-posp x) (math-posp b) | |
1624 (let* ((sign 1) (inv nil) | |
1625 (xx (if (Math-lessp 1 x) | |
1626 x | |
1627 (setq sign -1) | |
1628 (math-div 1 x))) | |
1629 (bb (if (Math-lessp 1 b) | |
1630 b | |
1631 (setq sign (- sign)) | |
1632 (math-div 1 b))) | |
1633 (res (if (Math-lessp xx bb) | |
1634 (setq inv (math-integer-log bb xx)) | |
1635 (math-integer-log xx bb)))) | |
1636 (and (car res) | |
1637 (setq x (if inv | |
1638 (math-div 1 (* sign (cdr res))) | |
1639 (* sign (cdr res))))))) | |
1640 x) | |
1641 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1642 ((and (Math-numberp x) (Math-numberp b)) | |
1643 (math-with-extra-prec 2 | |
1644 (math-div (math-ln-raw (math-float x)) | |
1645 (math-log-base-raw b)))) | |
1646 ((and (eq (car-safe x) 'sdev) | |
1647 (Math-numberp b)) | |
1648 (math-make-sdev (calcFunc-log (nth 1 x) b) | |
1649 (math-div (nth 2 x) | |
1650 (math-mul (nth 1 x) | |
1651 (math-log-base-raw b))))) | |
1652 ((and (eq (car-safe x) 'intv) (or (Math-posp (nth 2 x)) | |
1653 (not (math-intv-constp x))) | |
1654 (math-realp b)) | |
1655 (math-make-intv (nth 1 x) | |
1656 (calcFunc-log (nth 2 x) b) | |
1657 (calcFunc-log (nth 3 x) b))) | |
1658 ((or (eq (car-safe x) 'intv) (eq (car-safe b) 'intv)) | |
1659 (math-div (calcFunc-ln x) (calcFunc-ln b))) | |
1660 ((or (math-infinitep x) | |
1661 (math-infinitep b)) | |
1662 (math-div (calcFunc-ln x) (calcFunc-ln b))) | |
1663 (t (if (Math-numberp b) | |
1664 (calc-record-why 'numberp x) | |
1665 (calc-record-why 'numberp b)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1666 (list 'calcFunc-log x b)))) |
40785 | 1667 |
1668 (defun calcFunc-alog (x &optional b) | |
1669 (cond ((or (null b) (equal b '(var e var-e))) | |
1670 (math-normalize (list 'calcFunc-exp x))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1671 (t (math-pow b x)))) |
40785 | 1672 |
1673 (defun calcFunc-ilog (x b) | |
1674 (if (and (math-natnump x) (not (eq x 0)) | |
1675 (math-natnump b) (not (eq b 0))) | |
1676 (if (eq b 1) | |
1677 (math-reject-arg x "*Logarithm base one") | |
1678 (if (Math-natnum-lessp x b) | |
1679 0 | |
1680 (cdr (math-integer-log x b)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1681 (math-floor (calcFunc-log x b)))) |
40785 | 1682 |
1683 (defun math-integer-log (x b) | |
1684 (let ((pows (list b)) | |
1685 (pow (math-sqr b)) | |
1686 next | |
1687 sum n) | |
1688 (while (not (Math-lessp x pow)) | |
1689 (setq pows (cons pow pows) | |
1690 pow (math-sqr pow))) | |
1691 (setq n (lsh 1 (1- (length pows))) | |
1692 sum n | |
1693 pow (car pows)) | |
1694 (while (and (setq pows (cdr pows)) | |
1695 (Math-lessp pow x)) | |
1696 (setq n (/ n 2) | |
1697 next (math-mul pow (car pows))) | |
1698 (or (Math-lessp x next) | |
1699 (setq pow next | |
1700 sum (+ sum n)))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1701 (cons (equal pow x) sum))) |
40785 | 1702 |
1703 | |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41044
diff
changeset
|
1704 (defvar math-log-base-cache nil) |
40785 | 1705 (defun math-log-base-raw (b) ; [N N] |
1706 (if (not (and (equal (car math-log-base-cache) b) | |
1707 (eq (nth 1 math-log-base-cache) calc-internal-prec))) | |
1708 (setq math-log-base-cache (list b calc-internal-prec | |
1709 (math-ln-raw (math-float b))))) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1710 (nth 2 math-log-base-cache)) |
40785 | 1711 |
1712 (defun calcFunc-lnp1 (x) ; [N N] [Public] | |
1713 (cond ((Math-equal-int x -1) | |
1714 (if calc-infinite-mode | |
1715 '(neg (var inf var-inf)) | |
1716 (math-reject-arg x "*Logarithm of zero"))) | |
1717 ((eq x 0) 0) | |
1718 ((math-zerop x) '(float 0 0)) | |
1719 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1720 ((Math-numberp x) | |
1721 (math-with-extra-prec 2 | |
1722 (let ((x (math-float x))) | |
1723 (if (and (eq (car x) 'float) | |
1724 (math-lessp-float x '(float 5 -1)) | |
1725 (math-lessp-float '(float -5 -1) x)) | |
1726 (math-ln-plus-1-raw x) | |
1727 (math-ln-raw (math-add-float x '(float 1 0))))))) | |
1728 ((eq (car-safe x) 'sdev) | |
1729 (math-make-sdev (calcFunc-lnp1 (nth 1 x)) | |
1730 (math-div (nth 2 x) (math-add (nth 1 x) 1)))) | |
1731 ((and (eq (car-safe x) 'intv) (or (Math-posp (nth 2 x)) | |
1732 (not (math-intv-constp x)))) | |
1733 (math-make-intv (nth 1 x) | |
1734 (calcFunc-lnp1 (nth 2 x)) | |
1735 (calcFunc-lnp1 (nth 3 x)))) | |
1736 ((math-infinitep x) | |
1737 (if (equal x '(var nan var-nan)) | |
1738 x | |
1739 '(var inf var-inf))) | |
1740 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1741 (list 'calcFunc-lnp1 x)))) |
40785 | 1742 |
1743 (defun math-ln-raw (x) ; [N N] --- must be float format! | |
1744 (cond ((eq (car-safe x) 'cplx) | |
1745 (list 'cplx | |
1746 (math-mul-float (math-ln-raw | |
1747 (math-add-float (math-sqr-float (nth 1 x)) | |
1748 (math-sqr-float (nth 2 x)))) | |
1749 '(float 5 -1)) | |
1750 (math-arctan2-raw (nth 2 x) (nth 1 x)))) | |
1751 ((eq (car x) 'polar) | |
1752 (math-polar (list 'cplx | |
1753 (math-ln-raw (nth 1 x)) | |
1754 (math-to-radians (nth 2 x))))) | |
1755 ((Math-equal-int x 1) | |
1756 '(float 0 0)) | |
1757 (calc-symbolic-mode (signal 'inexact-result nil)) | |
1758 ((math-posp (nth 1 x)) ; positive and real | |
82238
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
1759 (cond |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
1760 ((math-use-emacs-fn 'log x)) |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
1761 (t |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
1762 (let ((xdigs (1- (math-numdigs (nth 1 x))))) |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
1763 (math-add-float (math-ln-raw-2 (list 'float (nth 1 x) (- xdigs))) |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
1764 (math-mul-float (math-float (+ (nth 2 x) xdigs)) |
78ac1f6cc5cc
(math-sqrt-raw,math-sin-raw-2,math-cos-raw-2,math-arctan-raw)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82140
diff
changeset
|
1765 (math-ln-10))))))) |
40785 | 1766 ((math-zerop x) |
1767 (math-reject-arg x "*Logarithm of zero")) | |
1768 ((eq calc-complex-mode 'polar) ; negative and real | |
1769 (math-polar | |
1770 (list 'cplx ; negative and real | |
1771 (math-ln-raw (math-neg-float x)) | |
1772 (math-pi)))) | |
1773 (t (list 'cplx ; negative and real | |
1774 (math-ln-raw (math-neg-float x)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1775 (math-pi))))) |
40785 | 1776 |
1777 (defun math-ln-raw-2 (x) ; [F F] | |
1778 (cond ((math-lessp-float '(float 14 -1) x) | |
1779 (math-add-float (math-ln-raw-2 (math-mul-float x '(float 5 -1))) | |
1780 (math-ln-2))) | |
1781 (t ; now .7 < x <= 1.4 | |
1782 (math-ln-raw-3 (math-div-float (math-sub-float x '(float 1 0)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1783 (math-add-float x '(float 1 0))))))) |
40785 | 1784 |
1785 (defun math-ln-raw-3 (x) ; [F F] | |
1786 (math-mul-float (math-ln-raw-series x 3 x (math-sqr-float x)) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1787 '(float 2 0))) |
40785 | 1788 |
1789 ;;; Compute ln((1+x)/(1-x)) | |
1790 (defun math-ln-raw-series (sum n x xsqr) | |
1791 (math-working "log" sum) | |
1792 (let* ((nextx (math-mul-float x xsqr)) | |
1793 (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) | |
1794 (if (math-nearly-equal-float sum nextsum) | |
1795 sum | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1796 (math-ln-raw-series nextsum (+ n 2) nextx xsqr)))) |
40785 | 1797 |
1798 (defun math-ln-plus-1-raw (x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1799 (math-lnp1-series x 2 x (math-neg x))) |
40785 | 1800 |
1801 (defun math-lnp1-series (sum n xpow x) | |
1802 (math-working "lnp1" sum) | |
1803 (let* ((nextx (math-mul-float xpow x)) | |
1804 (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) | |
1805 (if (math-nearly-equal-float sum nextsum) | |
1806 sum | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1807 (math-lnp1-series nextsum (1+ n) nextx x)))) |
40785 | 1808 |
81549
95971e0a7e98
(math-approx-ln-10, math-approx-ln-2): New variables to use in caches.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
77465
diff
changeset
|
1809 (defconst math-approx-ln-10 |
82443
5d2017af3365
(math-approx-ln-10, math-approx-ln-2): Remove `eval-when-compile's.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82238
diff
changeset
|
1810 (math-read-number-simple "2.302585092994045684018") |
81746
71ae866366dc
(math-approx-ln-10,math-approx-ln-2): Add docstrings.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81597
diff
changeset
|
1811 "An approximation for ln(10).") |
81549
95971e0a7e98
(math-approx-ln-10, math-approx-ln-2): New variables to use in caches.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
77465
diff
changeset
|
1812 |
95971e0a7e98
(math-approx-ln-10, math-approx-ln-2): New variables to use in caches.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
77465
diff
changeset
|
1813 (math-defcache math-ln-10 math-approx-ln-10 |
40785 | 1814 (math-ln-raw-2 '(float 1 1))) |
1815 | |
81549
95971e0a7e98
(math-approx-ln-10, math-approx-ln-2): New variables to use in caches.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
77465
diff
changeset
|
1816 (defconst math-approx-ln-2 |
82443
5d2017af3365
(math-approx-ln-10, math-approx-ln-2): Remove `eval-when-compile's.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
82238
diff
changeset
|
1817 (math-read-number-simple "0.693147180559945309417") |
81746
71ae866366dc
(math-approx-ln-10,math-approx-ln-2): Add docstrings.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
81597
diff
changeset
|
1818 "An approximation for ln(2).") |
81549
95971e0a7e98
(math-approx-ln-10, math-approx-ln-2): New variables to use in caches.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
77465
diff
changeset
|
1819 |
95971e0a7e98
(math-approx-ln-10, math-approx-ln-2): New variables to use in caches.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
77465
diff
changeset
|
1820 (math-defcache math-ln-2 math-approx-ln-2 |
40785 | 1821 (math-ln-raw-3 (math-float '(frac 1 3)))) |
1822 | |
1823 | |
1824 | |
1825 ;;; Hyperbolic functions. | |
1826 | |
1827 (defun calcFunc-sinh (x) ; [N N] [Public] | |
1828 (cond ((eq x 0) 0) | |
1829 (math-expand-formulas | |
1830 (math-normalize | |
1831 (list '/ (list '- (list 'calcFunc-exp x) | |
1832 (list 'calcFunc-exp (list 'neg x))) 2))) | |
1833 ((Math-numberp x) | |
1834 (if calc-symbolic-mode (signal 'inexact-result nil)) | |
1835 (math-with-extra-prec 2 | |
1836 (let ((expx (math-exp-raw (math-float x)))) | |
1837 (math-mul (math-add expx (math-div -1 expx)) '(float 5 -1))))) | |
1838 ((eq (car-safe x) 'sdev) | |
1839 (math-make-sdev (calcFunc-sinh (nth 1 x)) | |
1840 (math-mul (nth 2 x) (calcFunc-cosh (nth 1 x))))) | |
1841 ((eq (car x) 'intv) | |
1842 (math-sort-intv (nth 1 x) | |
1843 (calcFunc-sinh (nth 2 x)) | |
1844 (calcFunc-sinh (nth 3 x)))) | |
1845 ((or (equal x '(var inf var-inf)) | |
1846 (equal x '(neg (var inf var-inf))) | |
1847 (equal x '(var nan var-nan))) | |
1848 x) | |
1849 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1850 (list 'calcFunc-sinh x)))) |
40785 | 1851 (put 'calcFunc-sinh 'math-expandable t) |
1852 | |
1853 (defun calcFunc-cosh (x) ; [N N] [Public] | |
1854 (cond ((eq x 0) 1) | |
1855 (math-expand-formulas | |
1856 (math-normalize | |
1857 (list '/ (list '+ (list 'calcFunc-exp x) | |
1858 (list 'calcFunc-exp (list 'neg x))) 2))) | |
1859 ((Math-numberp x) | |
1860 (if calc-symbolic-mode (signal 'inexact-result nil)) | |
1861 (math-with-extra-prec 2 | |
1862 (let ((expx (math-exp-raw (math-float x)))) | |
1863 (math-mul (math-add expx (math-div 1 expx)) '(float 5 -1))))) | |
1864 ((eq (car-safe x) 'sdev) | |
1865 (math-make-sdev (calcFunc-cosh (nth 1 x)) | |
1866 (math-mul (nth 2 x) | |
1867 (calcFunc-sinh (nth 1 x))))) | |
1868 ((and (eq (car x) 'intv) (math-intv-constp x)) | |
1869 (setq x (math-abs x)) | |
1870 (math-sort-intv (nth 1 x) | |
1871 (calcFunc-cosh (nth 2 x)) | |
1872 (calcFunc-cosh (nth 3 x)))) | |
1873 ((or (equal x '(var inf var-inf)) | |
1874 (equal x '(neg (var inf var-inf))) | |
1875 (equal x '(var nan var-nan))) | |
1876 (math-abs x)) | |
1877 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1878 (list 'calcFunc-cosh x)))) |
40785 | 1879 (put 'calcFunc-cosh 'math-expandable t) |
1880 | |
1881 (defun calcFunc-tanh (x) ; [N N] [Public] | |
1882 (cond ((eq x 0) 0) | |
1883 (math-expand-formulas | |
1884 (math-normalize | |
1885 (let ((expx (list 'calcFunc-exp x)) | |
1886 (expmx (list 'calcFunc-exp (list 'neg x)))) | |
1887 (math-normalize | |
1888 (list '/ (list '- expx expmx) (list '+ expx expmx)))))) | |
1889 ((Math-numberp x) | |
1890 (if calc-symbolic-mode (signal 'inexact-result nil)) | |
1891 (math-with-extra-prec 2 | |
1892 (let* ((expx (calcFunc-exp (math-float x))) | |
1893 (expmx (math-div 1 expx))) | |
1894 (math-div (math-sub expx expmx) | |
1895 (math-add expx expmx))))) | |
1896 ((eq (car-safe x) 'sdev) | |
1897 (math-make-sdev (calcFunc-tanh (nth 1 x)) | |
1898 (math-div (nth 2 x) | |
1899 (math-sqr (calcFunc-cosh (nth 1 x)))))) | |
1900 ((eq (car x) 'intv) | |
1901 (math-sort-intv (nth 1 x) | |
1902 (calcFunc-tanh (nth 2 x)) | |
1903 (calcFunc-tanh (nth 3 x)))) | |
1904 ((equal x '(var inf var-inf)) | |
1905 1) | |
1906 ((equal x '(neg (var inf var-inf))) | |
1907 -1) | |
1908 ((equal x '(var nan var-nan)) | |
1909 x) | |
1910 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
1911 (list 'calcFunc-tanh x)))) |
40785 | 1912 (put 'calcFunc-tanh 'math-expandable t) |
1913 | |
60079
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1914 (defun calcFunc-sech (x) ; [N N] [Public] |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1915 (cond ((eq x 0) 1) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1916 (math-expand-formulas |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1917 (math-normalize |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1918 (list '/ 2 (list '+ (list 'calcFunc-exp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1919 (list 'calcFunc-exp (list 'neg x)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1920 ((Math-numberp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1921 (if calc-symbolic-mode (signal 'inexact-result nil)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1922 (math-with-extra-prec 2 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1923 (let ((expx (math-exp-raw (math-float x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1924 (math-div '(float 2 0) (math-add expx (math-div 1 expx)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1925 ((eq (car-safe x) 'sdev) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1926 (math-make-sdev (calcFunc-sech (nth 1 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1927 (math-mul (nth 2 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1928 (math-mul (calcFunc-sech (nth 1 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1929 (calcFunc-tanh (nth 1 x)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1930 ((and (eq (car x) 'intv) (math-intv-constp x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1931 (setq x (math-abs x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1932 (math-sort-intv (nth 1 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1933 (calcFunc-sech (nth 2 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1934 (calcFunc-sech (nth 3 x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1935 ((or (equal x '(var inf var-inf)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1936 (equal x '(neg (var inf var-inf)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1937 0) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1938 ((equal x '(var nan var-nan)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1939 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1940 (t (calc-record-why 'numberp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1941 (list 'calcFunc-sech x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1942 (put 'calcFunc-sech 'math-expandable t) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1943 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1944 (defun calcFunc-csch (x) ; [N N] [Public] |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1945 (cond ((eq x 0) (math-div 1 0)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1946 (math-expand-formulas |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1947 (math-normalize |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1948 (list '/ 2 (list '- (list 'calcFunc-exp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1949 (list 'calcFunc-exp (list 'neg x)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1950 ((Math-numberp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1951 (if calc-symbolic-mode (signal 'inexact-result nil)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1952 (math-with-extra-prec 2 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1953 (let ((expx (math-exp-raw (math-float x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1954 (math-div '(float 2 0) (math-add expx (math-div -1 expx)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1955 ((eq (car-safe x) 'sdev) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1956 (math-make-sdev (calcFunc-csch (nth 1 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1957 (math-mul (nth 2 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1958 (math-mul (calcFunc-csch (nth 1 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1959 (calcFunc-coth (nth 1 x)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1960 ((eq (car x) 'intv) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1961 (if (and (Math-negp (nth 2 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1962 (Math-posp (nth 3 x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1963 '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1964 (math-sort-intv (nth 1 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1965 (calcFunc-csch (nth 2 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1966 (calcFunc-csch (nth 3 x))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1967 ((or (equal x '(var inf var-inf)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1968 (equal x '(neg (var inf var-inf)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1969 0) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1970 ((equal x '(var nan var-nan)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1971 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1972 (t (calc-record-why 'numberp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1973 (list 'calcFunc-csch x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1974 (put 'calcFunc-csch 'math-expandable t) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1975 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1976 (defun calcFunc-coth (x) ; [N N] [Public] |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1977 (cond ((eq x 0) (math-div 1 0)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1978 (math-expand-formulas |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1979 (math-normalize |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1980 (let ((expx (list 'calcFunc-exp x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1981 (expmx (list 'calcFunc-exp (list 'neg x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1982 (math-normalize |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1983 (list '/ (list '+ expx expmx) (list '- expx expmx)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1984 ((Math-numberp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1985 (if calc-symbolic-mode (signal 'inexact-result nil)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1986 (math-with-extra-prec 2 |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1987 (let* ((expx (calcFunc-exp (math-float x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1988 (expmx (math-div 1 expx))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1989 (math-div (math-add expx expmx) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1990 (math-sub expx expmx))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1991 ((eq (car-safe x) 'sdev) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1992 (math-make-sdev (calcFunc-coth (nth 1 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1993 (math-div (nth 2 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1994 (math-sqr (calcFunc-sinh (nth 1 x)))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1995 ((eq (car x) 'intv) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1996 (if (and (Math-negp (nth 2 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1997 (Math-posp (nth 3 x))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1998 '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
1999 (math-sort-intv (nth 1 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
2000 (calcFunc-coth (nth 2 x)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
2001 (calcFunc-coth (nth 3 x))))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
2002 ((equal x '(var inf var-inf)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
2003 1) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
2004 ((equal x '(neg (var inf var-inf))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
2005 -1) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
2006 ((equal x '(var nan var-nan)) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
2007 x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
2008 (t (calc-record-why 'numberp x) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
2009 (list 'calcFunc-coth x)))) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
2010 (put 'calcFunc-coth 'math-expandable t) |
b676ef11ff65
(calc-sec, calc-csc, calc-cot, calc-sech, calc-csch, calc-coth)
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58663
diff
changeset
|
2011 |
40785 | 2012 (defun calcFunc-arcsinh (x) ; [N N] [Public] |
2013 (cond ((eq x 0) 0) | |
2014 (math-expand-formulas | |
2015 (math-normalize | |
2016 (list 'calcFunc-ln (list '+ x (list 'calcFunc-sqrt | |
2017 (list '+ (list '^ x 2) 1)))))) | |
2018 ((Math-numberp x) | |
2019 (if calc-symbolic-mode (signal 'inexact-result nil)) | |
2020 (math-with-extra-prec 2 | |
2021 (math-ln-raw (math-add x (math-sqrt-raw (math-add (math-sqr x) | |
2022 '(float 1 0))))))) | |
2023 ((eq (car-safe x) 'sdev) | |
2024 (math-make-sdev (calcFunc-arcsinh (nth 1 x)) | |
2025 (math-div (nth 2 x) | |
2026 (math-sqrt | |
2027 (math-add (math-sqr (nth 1 x)) 1))))) | |
2028 ((eq (car x) 'intv) | |
2029 (math-sort-intv (nth 1 x) | |
2030 (calcFunc-arcsinh (nth 2 x)) | |
2031 (calcFunc-arcsinh (nth 3 x)))) | |
2032 ((or (equal x '(var inf var-inf)) | |
2033 (equal x '(neg (var inf var-inf))) | |
2034 (equal x '(var nan var-nan))) | |
2035 x) | |
2036 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
2037 (list 'calcFunc-arcsinh x)))) |
40785 | 2038 (put 'calcFunc-arcsinh 'math-expandable t) |
2039 | |
2040 (defun calcFunc-arccosh (x) ; [N N] [Public] | |
2041 (cond ((eq x 1) 0) | |
2042 ((and (eq x -1) calc-symbolic-mode) | |
2043 '(var pi var-pi)) | |
2044 ((and (eq x 0) calc-symbolic-mode) | |
2045 (math-div (math-mul '(var pi var-pi) '(var i var-i)) 2)) | |
2046 (math-expand-formulas | |
2047 (math-normalize | |
2048 (list 'calcFunc-ln (list '+ x (list 'calcFunc-sqrt | |
2049 (list '- (list '^ x 2) 1)))))) | |
2050 ((Math-numberp x) | |
2051 (if calc-symbolic-mode (signal 'inexact-result nil)) | |
2052 (if (Math-equal-int x -1) | |
2053 (math-imaginary (math-pi)) | |
2054 (math-with-extra-prec 2 | |
2055 (if (or t ; need to do this even in the real case! | |
2056 (memq (car-safe x) '(cplx polar))) | |
2057 (let ((xp1 (math-add 1 x))) ; this gets the branch cuts right | |
2058 (math-ln-raw | |
2059 (math-add x (math-mul xp1 | |
2060 (math-sqrt-raw | |
2061 (math-div (math-sub | |
2062 x | |
2063 '(float 1 0)) | |
2064 xp1)))))) | |
2065 (math-ln-raw | |
2066 (math-add x (math-sqrt-raw (math-add (math-sqr x) | |
2067 '(float -1 0))))))))) | |
2068 ((eq (car-safe x) 'sdev) | |
2069 (math-make-sdev (calcFunc-arccosh (nth 1 x)) | |
2070 (math-div (nth 2 x) | |
2071 (math-sqrt | |
2072 (math-add (math-sqr (nth 1 x)) -1))))) | |
2073 ((eq (car x) 'intv) | |
2074 (math-sort-intv (nth 1 x) | |
2075 (calcFunc-arccosh (nth 2 x)) | |
2076 (calcFunc-arccosh (nth 3 x)))) | |
2077 ((or (equal x '(var inf var-inf)) | |
2078 (equal x '(neg (var inf var-inf))) | |
2079 (equal x '(var nan var-nan))) | |
2080 x) | |
2081 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
2082 (list 'calcFunc-arccosh x)))) |
40785 | 2083 (put 'calcFunc-arccosh 'math-expandable t) |
2084 | |
2085 (defun calcFunc-arctanh (x) ; [N N] [Public] | |
2086 (cond ((eq x 0) 0) | |
2087 ((and (Math-equal-int x 1) calc-infinite-mode) | |
2088 '(var inf var-inf)) | |
2089 ((and (Math-equal-int x -1) calc-infinite-mode) | |
2090 '(neg (var inf var-inf))) | |
2091 (math-expand-formulas | |
2092 (list '/ (list '- | |
2093 (list 'calcFunc-ln (list '+ 1 x)) | |
2094 (list 'calcFunc-ln (list '- 1 x))) 2)) | |
2095 ((Math-numberp x) | |
2096 (if calc-symbolic-mode (signal 'inexact-result nil)) | |
2097 (math-with-extra-prec 2 | |
2098 (if (or (memq (car-safe x) '(cplx polar)) | |
2099 (Math-lessp 1 x)) | |
2100 (math-mul (math-sub (math-ln-raw (math-add '(float 1 0) x)) | |
2101 (math-ln-raw (math-sub '(float 1 0) x))) | |
2102 '(float 5 -1)) | |
2103 (if (and (math-equal-int x 1) calc-infinite-mode) | |
2104 '(var inf var-inf) | |
2105 (if (and (math-equal-int x -1) calc-infinite-mode) | |
2106 '(neg (var inf var-inf)) | |
2107 (math-mul (math-ln-raw (math-div (math-add '(float 1 0) x) | |
2108 (math-sub 1 x))) | |
2109 '(float 5 -1))))))) | |
2110 ((eq (car-safe x) 'sdev) | |
2111 (math-make-sdev (calcFunc-arctanh (nth 1 x)) | |
2112 (math-div (nth 2 x) | |
2113 (math-sub 1 (math-sqr (nth 1 x)))))) | |
2114 ((eq (car x) 'intv) | |
2115 (math-sort-intv (nth 1 x) | |
2116 (calcFunc-arctanh (nth 2 x)) | |
2117 (calcFunc-arctanh (nth 3 x)))) | |
2118 ((equal x '(var nan var-nan)) | |
2119 x) | |
2120 (t (calc-record-why 'numberp x) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
2121 (list 'calcFunc-arctanh x)))) |
40785 | 2122 (put 'calcFunc-arctanh 'math-expandable t) |
2123 | |
2124 | |
2125 ;;; Convert A from HMS or degrees to radians. | |
2126 (defun calcFunc-rad (a) ; [R R] [Public] | |
2127 (cond ((or (Math-numberp a) | |
2128 (eq (car a) 'intv)) | |
2129 (math-with-extra-prec 2 | |
2130 (math-mul a (math-pi-over-180)))) | |
2131 ((eq (car a) 'hms) | |
2132 (math-from-hms a 'rad)) | |
2133 ((eq (car a) 'sdev) | |
2134 (math-make-sdev (calcFunc-rad (nth 1 a)) | |
2135 (calcFunc-rad (nth 2 a)))) | |
2136 (math-expand-formulas | |
2137 (math-div (math-mul a '(var pi var-pi)) 180)) | |
2138 ((math-infinitep a) a) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
2139 (t (list 'calcFunc-rad a)))) |
40785 | 2140 (put 'calcFunc-rad 'math-expandable t) |
2141 | |
2142 ;;; Convert A from HMS or radians to degrees. | |
2143 (defun calcFunc-deg (a) ; [R R] [Public] | |
2144 (cond ((or (Math-numberp a) | |
2145 (eq (car a) 'intv)) | |
2146 (math-with-extra-prec 2 | |
2147 (math-div a (math-pi-over-180)))) | |
2148 ((eq (car a) 'hms) | |
2149 (math-from-hms a 'deg)) | |
2150 ((eq (car a) 'sdev) | |
2151 (math-make-sdev (calcFunc-deg (nth 1 a)) | |
2152 (calcFunc-deg (nth 2 a)))) | |
2153 (math-expand-formulas | |
2154 (math-div (math-mul 180 a) '(var pi var-pi))) | |
2155 ((math-infinitep a) a) | |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
2156 (t (list 'calcFunc-deg a)))) |
40785 | 2157 (put 'calcFunc-deg 'math-expandable t) |
2158 | |
58663
7ed196c06460
Add a provide statement.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58475
diff
changeset
|
2159 (provide 'calc-math) |
7ed196c06460
Add a provide statement.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58475
diff
changeset
|
2160 |
93975
1e3a407766b9
Fix up comment convention on the arch-tag lines.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
91997
diff
changeset
|
2161 ;; arch-tag: c7367e8e-d0b8-4f70-8577-2fb3f31dbb4c |
41044
4549dec29728
(calcFunc-sqrt, calcFunc-hypot): Use `defalias' instead of `fset' and
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
2162 ;;; calc-math.el ends here |