41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
1 ;;; calc-stuff.el --- miscellaneous functions for Calc
|
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
2
|
64325
|
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
|
106815
|
4 ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
5
|
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
6 ;; Author: David Gillespie <daveg@synaptics.com>
|
77465
|
7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
|
40785
|
8
|
|
9 ;; This file is part of GNU Emacs.
|
|
10
|
94654
|
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
|
76595
|
12 ;; it under the terms of the GNU General Public License as published by
|
94654
|
13 ;; the Free Software Foundation, either version 3 of the License, or
|
|
14 ;; (at your option) any later version.
|
40785
|
15
|
76595
|
16 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
19 ;; GNU General Public License for more details.
|
|
20
|
|
21 ;; You should have received a copy of the GNU General Public License
|
94654
|
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>
diff
changeset
|
24 ;;; Commentary:
|
40785
|
25
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
26 ;;; Code:
|
40785
|
27
|
|
28 ;; This file is autoloaded from calc-ext.el.
|
58674
|
29
|
40785
|
30 (require 'calc-ext)
|
|
31 (require 'calc-macs)
|
|
32
|
|
33 (defun calc-num-prefix (n)
|
|
34 "Use the number at the top of stack as the numeric prefix for the next command.
|
|
35 With a prefix, push that prefix as a number onto the stack."
|
|
36 (interactive "P")
|
|
37 (calc-wrapper
|
|
38 (if n
|
|
39 (calc-enter-result 0 "" (prefix-numeric-value n))
|
|
40 (let ((num (calc-top 1)))
|
|
41 (if (math-messy-integerp num)
|
|
42 (setq num (math-trunc num)))
|
|
43 (or (integerp num)
|
|
44 (error "Argument must be a small integer"))
|
|
45 (calc-pop-stack 1)
|
|
46 (setq prefix-arg num)
|
41047
|
47 (message "%d-" num))))) ; a (lame) simulation of the real thing...
|
40785
|
48
|
|
49
|
|
50 (defun calc-more-recursion-depth (n)
|
|
51 (interactive "P")
|
|
52 (calc-wrapper
|
|
53 (if (calc-is-inverse)
|
|
54 (calc-less-recursion-depth n)
|
|
55 (let ((n (if n (prefix-numeric-value n) 2)))
|
|
56 (if (> n 1)
|
|
57 (setq max-specpdl-size (* max-specpdl-size n)
|
|
58 max-lisp-eval-depth (* max-lisp-eval-depth n))))
|
41047
|
59 (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth))))
|
40785
|
60
|
|
61 (defun calc-less-recursion-depth (n)
|
|
62 (interactive "P")
|
|
63 (let ((n (if n (prefix-numeric-value n) 2)))
|
|
64 (if (> n 1)
|
|
65 (setq max-specpdl-size
|
|
66 (max (/ max-specpdl-size n) 600)
|
|
67 max-lisp-eval-depth
|
|
68 (max (/ max-lisp-eval-depth n) 200))))
|
41047
|
69 (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth))
|
40785
|
70
|
|
71
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
72 (defvar calc-which-why nil)
|
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
73 (defvar calc-last-why-command nil)
|
40785
|
74 (defun calc-explain-why (why &optional more)
|
|
75 (if (eq (car why) '*)
|
|
76 (setq why (cdr why)))
|
|
77 (let* ((pred (car why))
|
|
78 (arg (nth 1 why))
|
|
79 (msg (cond ((not pred) "Wrong type of argument")
|
|
80 ((stringp pred) pred)
|
|
81 ((eq pred 'integerp) "Integer expected")
|
|
82 ((eq pred 'natnump)
|
|
83 (if (and arg (Math-objvecp arg) (not (Math-integerp arg)))
|
|
84 "Integer expected"
|
|
85 "Nonnegative integer expected"))
|
|
86 ((eq pred 'posintp)
|
|
87 (if (and arg (Math-objvecp arg) (not (Math-integerp arg)))
|
|
88 "Integer expected"
|
|
89 "Positive integer expected"))
|
|
90 ((eq pred 'fixnump)
|
|
91 (if (and arg (Math-integerp arg))
|
|
92 "Small integer expected"
|
|
93 "Integer expected"))
|
|
94 ((eq pred 'fixnatnump)
|
|
95 (if (and arg (Math-natnump arg))
|
|
96 "Small integer expected"
|
|
97 (if (and arg (Math-objvecp arg)
|
|
98 (not (Math-integerp arg)))
|
|
99 "Integer expected"
|
|
100 "Nonnegative integer expected")))
|
|
101 ((eq pred 'fixposintp)
|
|
102 (if (and arg (Math-integerp arg) (Math-posp arg))
|
|
103 "Small integer expected"
|
|
104 (if (and arg (Math-objvecp arg)
|
|
105 (not (Math-integerp arg)))
|
|
106 "Integer expected"
|
|
107 "Positive integer expected")))
|
|
108 ((eq pred 'posp) "Positive number expected")
|
|
109 ((eq pred 'negp) "Negative number expected")
|
|
110 ((eq pred 'nonzerop) "Nonzero number expected")
|
|
111 ((eq pred 'realp) "Real number expected")
|
|
112 ((eq pred 'anglep) "Real number expected")
|
|
113 ((eq pred 'hmsp) "HMS form expected")
|
|
114 ((eq pred 'datep)
|
|
115 (if (and arg (Math-objectp arg)
|
|
116 (not (Math-realp arg)))
|
|
117 "Real number or date form expected"
|
|
118 "Date form expected"))
|
|
119 ((eq pred 'numberp) "Number expected")
|
|
120 ((eq pred 'scalarp) "Number expected")
|
|
121 ((eq pred 'vectorp) "Vector or matrix expected")
|
|
122 ((eq pred 'numvecp) "Number or vector expected")
|
|
123 ((eq pred 'matrixp) "Matrix expected")
|
|
124 ((eq pred 'square-matrixp)
|
|
125 (if (and arg (math-matrixp arg))
|
|
126 "Square matrix expected"
|
|
127 "Matrix expected"))
|
|
128 ((eq pred 'objectp) "Number expected")
|
|
129 ((eq pred 'constp) "Constant expected")
|
|
130 ((eq pred 'range) "Argument out of range")
|
|
131 (t (format "%s expected" pred))))
|
|
132 (punc ": ")
|
|
133 (calc-can-abbrev-vectors t))
|
|
134 (while (setq why (cdr why))
|
|
135 (and (car why)
|
|
136 (setq msg (concat msg punc (if (stringp (car why))
|
|
137 (car why)
|
|
138 (math-format-flat-expr (car why) 0)))
|
|
139 punc ", ")))
|
41047
|
140 (message "%s%s" msg (if more " [w=more]" ""))))
|
40785
|
141
|
|
142 (defun calc-why ()
|
|
143 (interactive)
|
|
144 (if (not (eq this-command last-command))
|
|
145 (if (eq last-command calc-last-why-command)
|
|
146 (setq calc-which-why (cdr calc-why))
|
|
147 (setq calc-which-why calc-why)))
|
|
148 (if calc-which-why
|
|
149 (progn
|
|
150 (calc-explain-why (car calc-which-why) (cdr calc-which-why))
|
|
151 (setq calc-which-why (cdr calc-which-why)))
|
|
152 (if calc-why
|
|
153 (progn
|
|
154 (message "(No further explanations available)")
|
|
155 (setq calc-which-why calc-why))
|
41047
|
156 (message "No explanations available"))))
|
40785
|
157
|
58546
|
158 ;; The following caches are declared in other files, but are
|
|
159 ;; reset here.
|
|
160 (defvar math-lud-cache) ; calc-mtx.el
|
|
161 (defvar math-log2-cache) ; calc-bin.el
|
|
162 (defvar math-radix-digits-cache) ; calc-bin.el
|
|
163 (defvar math-radix-float-cache-tag) ; calc-bin.el
|
|
164 (defvar math-random-cache) ; calc-comb.el
|
|
165 (defvar math-max-digits-cache) ; calc-bin.el
|
|
166 (defvar math-integral-cache) ; calcalg2.el
|
|
167 (defvar math-units-table) ; calc-units.el
|
62833
|
168 (defvar math-decls-cache-tag) ; calc-arith.el
|
58546
|
169 (defvar math-format-date-cache) ; calc-forms.el
|
|
170 (defvar math-holidays-cache-tag) ; calc-forms.el
|
40785
|
171
|
47694
|
172 (defun calc-flush-caches (&optional inhibit-msg)
|
|
173 (interactive "P")
|
40785
|
174 (calc-wrapper
|
|
175 (setq math-lud-cache nil
|
|
176 math-log2-cache nil
|
|
177 math-radix-digits-cache nil
|
|
178 math-radix-float-cache-tag nil
|
|
179 math-random-cache nil
|
|
180 math-max-digits-cache nil
|
|
181 math-integral-cache nil
|
|
182 math-units-table nil
|
|
183 math-decls-cache-tag nil
|
|
184 math-eval-rules-cache-tag t
|
|
185 math-format-date-cache nil
|
|
186 math-holidays-cache-tag t)
|
84890
|
187 (mapc (function (lambda (x) (set x -100))) math-cache-list)
|
47694
|
188 (unless inhibit-msg
|
|
189 (message "All internal calculator caches have been reset"))))
|
40785
|
190
|
|
191
|
|
192 ;;; Conversions.
|
|
193
|
|
194 (defun calc-clean (n)
|
|
195 (interactive "P")
|
|
196 (calc-slow-wrapper
|
|
197 (calc-with-default-simplification
|
|
198 (let ((func (if (calc-is-hyperbolic) 'calcFunc-clean 'calcFunc-pclean)))
|
|
199 (calc-enter-result 1 "cln"
|
|
200 (if n
|
|
201 (let ((n (prefix-numeric-value n)))
|
|
202 (list func
|
|
203 (calc-top-n 1)
|
|
204 (if (<= n 0)
|
|
205 (+ n calc-internal-prec)
|
|
206 n)))
|
41047
|
207 (list func (calc-top-n 1))))))))
|
40785
|
208
|
|
209 (defun calc-clean-num (num)
|
|
210 (interactive "P")
|
|
211 (calc-clean (- (if num
|
49598
|
212 (prefix-numeric-value num)
|
101001
|
213 (if (and (>= last-command-event ?0)
|
|
214 (<= last-command-event ?9))
|
|
215 (- last-command-event ?0)
|
41047
|
216 (error "Number required"))))))
|
40785
|
217
|
|
218
|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
diff
changeset
|
219 (defvar math-chopping-small nil)
|
40785
|
220 (defun calcFunc-clean (a &optional prec) ; [X X S] [Public]
|
|
221 (if prec
|
|
222 (cond ((Math-messy-integerp prec)
|
|
223 (calcFunc-clean a (math-trunc prec)))
|
|
224 ((or (not (integerp prec))
|
|
225 (< prec 3))
|
|
226 (calc-record-why "*Precision must be an integer 3 or above")
|
|
227 (list 'calcFunc-clean a prec))
|
|
228 ((not (Math-objvecp a))
|
|
229 (list 'calcFunc-clean a prec))
|
|
230 (t (let ((calc-internal-prec prec)
|
|
231 (math-chopping-small t))
|
|
232 (calcFunc-clean (math-normalize a)))))
|
|
233 (cond ((eq (car-safe a) 'polar)
|
|
234 (let ((theta (math-mod (nth 2 a)
|
|
235 (if (eq calc-angle-mode 'rad)
|
|
236 (math-two-pi)
|
|
237 360))))
|
|
238 (math-neg
|
|
239 (math-neg
|
|
240 (math-normalize
|
|
241 (list 'polar
|
|
242 (calcFunc-clean (nth 1 a))
|
|
243 (calcFunc-clean theta)))))))
|
|
244 ((memq (car-safe a) '(vec date hms))
|
|
245 (cons (car a) (mapcar 'calcFunc-clean (cdr a))))
|
|
246 ((memq (car-safe a) '(cplx mod sdev intv))
|
|
247 (math-normalize (cons (car a) (mapcar 'calcFunc-clean (cdr a)))))
|
|
248 ((eq (car-safe a) 'float)
|
|
249 (if math-chopping-small
|
|
250 (if (or (> (nth 2 a) (- calc-internal-prec))
|
|
251 (Math-lessp (- calc-internal-prec) (calcFunc-xpon a)))
|
|
252 (if (and (math-num-integerp a)
|
|
253 (math-lessp (calcFunc-xpon a) calc-internal-prec))
|
|
254 (math-trunc a)
|
|
255 a)
|
|
256 0)
|
|
257 a))
|
|
258 ((Math-objectp a) a)
|
|
259 ((math-infinitep a) a)
|
41047
|
260 (t (list 'calcFunc-clean a)))))
|
40785
|
261
|
|
262 (defun calcFunc-pclean (a &optional prec)
|
|
263 (math-map-over-constants (function (lambda (x) (calcFunc-clean x prec)))
|
41047
|
264 a))
|
40785
|
265
|
|
266 (defun calcFunc-pfloat (a)
|
41047
|
267 (math-map-over-constants 'math-float a))
|
40785
|
268
|
|
269 (defun calcFunc-pfrac (a &optional tol)
|
|
270 (math-map-over-constants (function (lambda (x) (calcFunc-frac x tol)))
|
41047
|
271 a))
|
40785
|
272
|
58546
|
273 ;; The variable math-moc-func is local to math-map-over-constants,
|
|
274 ;; but is used by math-map-over-constants-rec, which is called by
|
|
275 ;; math-map-over-constants.
|
|
276 (defvar math-moc-func)
|
|
277
|
|
278 (defun math-map-over-constants (math-moc-func expr)
|
41047
|
279 (math-map-over-constants-rec expr))
|
40785
|
280
|
|
281 (defun math-map-over-constants-rec (expr)
|
|
282 (cond ((or (Math-primp expr)
|
|
283 (memq (car expr) '(intv sdev)))
|
|
284 (or (and (Math-objectp expr)
|
58546
|
285 (funcall math-moc-func expr))
|
40785
|
286 expr))
|
|
287 ((and (memq (car expr) '(^ calcFunc-subscr))
|
58546
|
288 (eq math-moc-func 'math-float)
|
40785
|
289 (= (length expr) 3)
|
|
290 (Math-integerp (nth 2 expr)))
|
|
291 (list (car expr)
|
|
292 (math-map-over-constants-rec (nth 1 expr))
|
|
293 (nth 2 expr)))
|
41047
|
294 (t (cons (car expr) (mapcar 'math-map-over-constants-rec (cdr expr))))))
|
40785
|
295
|
58674
|
296 (provide 'calc-stuff)
|
|
297
|
93975
|
298 ;; arch-tag: 789332ef-a178-49d3-8fb7-5d7ed7e21f56
|
41047
|
299 ;;; calc-stuff.el ends here
|