1 ;;; calc-stuff.el --- miscellaneous functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
6 ;; Author: David Gillespie <daveg@synaptics.com>
7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
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.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;; This file is autoloaded from calc-ext.el.
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."
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
)))
44 (error "Argument must be a small integer"))
47 (message "%d-" num
))))) ; a (lame) simulation of the real thing...
50 (defun calc-more-recursion-depth (n)
54 (calc-less-recursion-depth n
)
55 (let ((n (if n
(prefix-numeric-value n
) 2)))
57 (setq max-specpdl-size
(* max-specpdl-size n
)
58 max-lisp-eval-depth
(* max-lisp-eval-depth n
))))
59 (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth
))))
61 (defun calc-less-recursion-depth (n)
63 (let ((n (if n
(prefix-numeric-value n
) 2)))
65 (setq max-specpdl-size
66 (max (/ max-specpdl-size n
) 600)
68 (max (/ max-lisp-eval-depth n
) 200))))
69 (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth
))
72 (defvar calc-which-why nil
)
73 (defvar calc-last-why-command nil
)
74 (defun calc-explain-why (why &optional more
)
77 (let* ((pred (car why
))
79 (msg (cond ((not pred
) "Wrong type of argument")
81 ((eq pred
'integerp
) "Integer expected")
83 (if (and arg
(Math-objvecp arg
) (not (Math-integerp arg
)))
85 "Nonnegative integer expected"))
87 (if (and arg
(Math-objvecp arg
) (not (Math-integerp arg
)))
89 "Positive integer expected"))
91 (if (and arg
(Math-integerp arg
))
92 "Small 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
)))
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
)))
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")
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"
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
))))
133 (calc-can-abbrev-vectors t
))
134 (while (setq why
(cdr why
))
136 (setq msg
(concat msg punc
(if (stringp (car why
))
138 (math-format-flat-expr (car why
) 0)))
140 (message "%s%s" msg
(if more
" [w=more]" ""))))
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
)))
150 (calc-explain-why (car calc-which-why
) (cdr calc-which-why
))
151 (setq calc-which-why
(cdr calc-which-why
)))
154 (message "(No further explanations available)")
155 (setq calc-which-why calc-why
))
156 (message "No explanations available"))))
159 (defun calc-version ()
161 (message "Calc %s" calc-version
))
163 ;; The following caches are declared in other files, but are
165 (defvar math-lud-cache
) ; calc-mtx.el
166 (defvar math-log2-cache
) ; calc-bin.el
167 (defvar math-radix-digits-cache
) ; calc-bin.el
168 (defvar math-radix-float-cache-tag
) ; calc-bin.el
169 (defvar math-random-cache
) ; calc-comb.el
170 (defvar math-max-digits-cache
) ; calc-bin.el
171 (defvar math-integral-cache
) ; calcalg2.el
172 (defvar math-units-table
) ; calc-units.el
173 (defvar math-decls-cache-tag
) ; calc-arith.el
174 (defvar math-format-date-cache
) ; calc-forms.el
175 (defvar math-holidays-cache-tag
) ; calc-forms.el
177 (defun calc-flush-caches (&optional inhibit-msg
)
180 (setq math-lud-cache nil
182 math-radix-digits-cache nil
183 math-radix-float-cache-tag nil
184 math-random-cache nil
185 math-max-digits-cache nil
186 math-integral-cache nil
188 math-decls-cache-tag nil
189 math-eval-rules-cache-tag t
190 math-format-date-cache nil
191 math-holidays-cache-tag t
)
192 (mapc (function (lambda (x) (set x -
100))) math-cache-list
)
194 (message "All internal calculator caches have been reset"))))
199 (defun calc-clean (n)
202 (calc-with-default-simplification
203 (let ((func (if (calc-is-hyperbolic) 'calcFunc-clean
'calcFunc-pclean
)))
204 (calc-enter-result 1 "cln"
206 (let ((n (prefix-numeric-value n
)))
210 (+ n calc-internal-prec
)
212 (list func
(calc-top-n 1))))))))
214 (defun calc-clean-num (num)
216 (calc-clean (- (if num
217 (prefix-numeric-value num
)
218 (if (and (>= last-command-char ?
0)
219 (<= last-command-char ?
9))
220 (- last-command-char ?
0)
221 (error "Number required"))))))
224 (defvar math-chopping-small nil
)
225 (defun calcFunc-clean (a &optional prec
) ; [X X S] [Public]
227 (cond ((Math-messy-integerp prec
)
228 (calcFunc-clean a
(math-trunc prec
)))
229 ((or (not (integerp prec
))
231 (calc-record-why "*Precision must be an integer 3 or above")
232 (list 'calcFunc-clean a prec
))
233 ((not (Math-objvecp a
))
234 (list 'calcFunc-clean a prec
))
235 (t (let ((calc-internal-prec prec
)
236 (math-chopping-small t
))
237 (calcFunc-clean (math-normalize a
)))))
238 (cond ((eq (car-safe a
) 'polar
)
239 (let ((theta (math-mod (nth 2 a
)
240 (if (eq calc-angle-mode
'rad
)
247 (calcFunc-clean (nth 1 a
))
248 (calcFunc-clean theta
)))))))
249 ((memq (car-safe a
) '(vec date hms
))
250 (cons (car a
) (mapcar 'calcFunc-clean
(cdr a
))))
251 ((memq (car-safe a
) '(cplx mod sdev intv
))
252 (math-normalize (cons (car a
) (mapcar 'calcFunc-clean
(cdr a
)))))
253 ((eq (car-safe a
) 'float
)
254 (if math-chopping-small
255 (if (or (> (nth 2 a
) (- calc-internal-prec
))
256 (Math-lessp (- calc-internal-prec
) (calcFunc-xpon a
)))
257 (if (and (math-num-integerp a
)
258 (math-lessp (calcFunc-xpon a
) calc-internal-prec
))
264 ((math-infinitep a
) a
)
265 (t (list 'calcFunc-clean a
)))))
267 (defun calcFunc-pclean (a &optional prec
)
268 (math-map-over-constants (function (lambda (x) (calcFunc-clean x prec
)))
271 (defun calcFunc-pfloat (a)
272 (math-map-over-constants 'math-float a
))
274 (defun calcFunc-pfrac (a &optional tol
)
275 (math-map-over-constants (function (lambda (x) (calcFunc-frac x tol
)))
278 ;; The variable math-moc-func is local to math-map-over-constants,
279 ;; but is used by math-map-over-constants-rec, which is called by
280 ;; math-map-over-constants.
281 (defvar math-moc-func
)
283 (defun math-map-over-constants (math-moc-func expr
)
284 (math-map-over-constants-rec expr
))
286 (defun math-map-over-constants-rec (expr)
287 (cond ((or (Math-primp expr
)
288 (memq (car expr
) '(intv sdev
)))
289 (or (and (Math-objectp expr
)
290 (funcall math-moc-func expr
))
292 ((and (memq (car expr
) '(^ calcFunc-subscr
))
293 (eq math-moc-func
'math-float
)
295 (Math-integerp (nth 2 expr
)))
297 (math-map-over-constants-rec (nth 1 expr
))
299 (t (cons (car expr
) (mapcar 'math-map-over-constants-rec
(cdr expr
))))))
301 (provide 'calc-stuff
)
303 ;; arch-tag: 789332ef-a178-49d3-8fb7-5d7ed7e21f56
304 ;;; calc-stuff.el ends here