Mercurial > emacs
annotate lisp/calc/calc-stuff.el @ 46677:86e8d59e2e49
*** empty log message ***
author | Dave Love <fx@gnu.org> |
---|---|
date | Wed, 24 Jul 2002 23:01:32 +0000 |
parents | fcd507927105 |
children | c7b1f2c10ed4 |
rev | line source |
---|---|
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
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>
parents:
41047
diff
changeset
|
2 |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
4 |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
5 ;; Author: David Gillespie <daveg@synaptics.com> |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
6 ;; Maintainer: Colin Walters <walters@debian.org> |
40785 | 7 |
8 ;; This file is part of GNU Emacs. | |
9 | |
10 ;; GNU Emacs is distributed in the hope that it will be useful, | |
11 ;; but WITHOUT ANY WARRANTY. No author or distributor | |
12 ;; accepts responsibility to anyone for the consequences of using it | |
13 ;; or for whether it serves any particular purpose or works at all, | |
14 ;; unless he says so in writing. Refer to the GNU Emacs General Public | |
15 ;; License for full details. | |
16 | |
17 ;; Everyone is granted permission to copy, modify and redistribute | |
18 ;; GNU Emacs, but only under the conditions described in the | |
19 ;; GNU Emacs General Public License. A copy of this license is | |
20 ;; supposed to have been given to you along with GNU Emacs so you | |
21 ;; can know your rights and responsibilities. It should be in a | |
22 ;; file named COPYING. Among other things, the copyright notice | |
23 ;; and this notice must be preserved on all copies. | |
24 | |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
25 ;;; Commentary: |
40785 | 26 |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
27 ;;; Code: |
40785 | 28 |
29 ;; This file is autoloaded from calc-ext.el. | |
30 (require 'calc-ext) | |
31 | |
32 (require 'calc-macs) | |
33 | |
34 (defun calc-Need-calc-stuff () nil) | |
35 | |
36 | |
37 (defun calc-num-prefix (n) | |
38 "Use the number at the top of stack as the numeric prefix for the next command. | |
39 With a prefix, push that prefix as a number onto the stack." | |
40 (interactive "P") | |
41 (calc-wrapper | |
42 (if n | |
43 (calc-enter-result 0 "" (prefix-numeric-value n)) | |
44 (let ((num (calc-top 1))) | |
45 (if (math-messy-integerp num) | |
46 (setq num (math-trunc num))) | |
47 (or (integerp num) | |
48 (error "Argument must be a small integer")) | |
49 (calc-pop-stack 1) | |
50 (setq prefix-arg num) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
51 (message "%d-" num))))) ; a (lame) simulation of the real thing... |
40785 | 52 |
53 | |
54 (defun calc-more-recursion-depth (n) | |
55 (interactive "P") | |
56 (calc-wrapper | |
57 (if (calc-is-inverse) | |
58 (calc-less-recursion-depth n) | |
59 (let ((n (if n (prefix-numeric-value n) 2))) | |
60 (if (> n 1) | |
61 (setq max-specpdl-size (* max-specpdl-size n) | |
62 max-lisp-eval-depth (* max-lisp-eval-depth n)))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
63 (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth)))) |
40785 | 64 |
65 (defun calc-less-recursion-depth (n) | |
66 (interactive "P") | |
67 (let ((n (if n (prefix-numeric-value n) 2))) | |
68 (if (> n 1) | |
69 (setq max-specpdl-size | |
70 (max (/ max-specpdl-size n) 600) | |
71 max-lisp-eval-depth | |
72 (max (/ max-lisp-eval-depth n) 200)))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
73 (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth)) |
40785 | 74 |
75 | |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
76 (defvar calc-which-why nil) |
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
77 (defvar calc-last-why-command nil) |
40785 | 78 (defun calc-explain-why (why &optional more) |
79 (if (eq (car why) '*) | |
80 (setq why (cdr why))) | |
81 (let* ((pred (car why)) | |
82 (arg (nth 1 why)) | |
83 (msg (cond ((not pred) "Wrong type of argument") | |
84 ((stringp pred) pred) | |
85 ((eq pred 'integerp) "Integer expected") | |
86 ((eq pred 'natnump) | |
87 (if (and arg (Math-objvecp arg) (not (Math-integerp arg))) | |
88 "Integer expected" | |
89 "Nonnegative integer expected")) | |
90 ((eq pred 'posintp) | |
91 (if (and arg (Math-objvecp arg) (not (Math-integerp arg))) | |
92 "Integer expected" | |
93 "Positive integer expected")) | |
94 ((eq pred 'fixnump) | |
95 (if (and arg (Math-integerp arg)) | |
96 "Small integer expected" | |
97 "Integer expected")) | |
98 ((eq pred 'fixnatnump) | |
99 (if (and arg (Math-natnump arg)) | |
100 "Small integer expected" | |
101 (if (and arg (Math-objvecp arg) | |
102 (not (Math-integerp arg))) | |
103 "Integer expected" | |
104 "Nonnegative integer expected"))) | |
105 ((eq pred 'fixposintp) | |
106 (if (and arg (Math-integerp arg) (Math-posp arg)) | |
107 "Small integer expected" | |
108 (if (and arg (Math-objvecp arg) | |
109 (not (Math-integerp arg))) | |
110 "Integer expected" | |
111 "Positive integer expected"))) | |
112 ((eq pred 'posp) "Positive number expected") | |
113 ((eq pred 'negp) "Negative number expected") | |
114 ((eq pred 'nonzerop) "Nonzero number expected") | |
115 ((eq pred 'realp) "Real number expected") | |
116 ((eq pred 'anglep) "Real number expected") | |
117 ((eq pred 'hmsp) "HMS form expected") | |
118 ((eq pred 'datep) | |
119 (if (and arg (Math-objectp arg) | |
120 (not (Math-realp arg))) | |
121 "Real number or date form expected" | |
122 "Date form expected")) | |
123 ((eq pred 'numberp) "Number expected") | |
124 ((eq pred 'scalarp) "Number expected") | |
125 ((eq pred 'vectorp) "Vector or matrix expected") | |
126 ((eq pred 'numvecp) "Number or vector expected") | |
127 ((eq pred 'matrixp) "Matrix expected") | |
128 ((eq pred 'square-matrixp) | |
129 (if (and arg (math-matrixp arg)) | |
130 "Square matrix expected" | |
131 "Matrix expected")) | |
132 ((eq pred 'objectp) "Number expected") | |
133 ((eq pred 'constp) "Constant expected") | |
134 ((eq pred 'range) "Argument out of range") | |
135 (t (format "%s expected" pred)))) | |
136 (punc ": ") | |
137 (calc-can-abbrev-vectors t)) | |
138 (while (setq why (cdr why)) | |
139 (and (car why) | |
140 (setq msg (concat msg punc (if (stringp (car why)) | |
141 (car why) | |
142 (math-format-flat-expr (car why) 0))) | |
143 punc ", "))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
144 (message "%s%s" msg (if more " [w=more]" "")))) |
40785 | 145 |
146 (defun calc-why () | |
147 (interactive) | |
148 (if (not (eq this-command last-command)) | |
149 (if (eq last-command calc-last-why-command) | |
150 (setq calc-which-why (cdr calc-why)) | |
151 (setq calc-which-why calc-why))) | |
152 (if calc-which-why | |
153 (progn | |
154 (calc-explain-why (car calc-which-why) (cdr calc-which-why)) | |
155 (setq calc-which-why (cdr calc-which-why))) | |
156 (if calc-why | |
157 (progn | |
158 (message "(No further explanations available)") | |
159 (setq calc-which-why calc-why)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
160 (message "No explanations available")))) |
40785 | 161 |
162 | |
163 (defun calc-version () | |
164 (interactive) | |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
165 (message "Calc %s" calc-version)) |
40785 | 166 |
167 | |
168 (defun calc-flush-caches () | |
169 (interactive) | |
170 (calc-wrapper | |
171 (setq math-lud-cache nil | |
172 math-log2-cache nil | |
173 math-radix-digits-cache nil | |
174 math-radix-float-cache-tag nil | |
175 math-random-cache nil | |
176 math-max-digits-cache nil | |
177 math-checked-rewrites nil | |
178 math-integral-cache nil | |
179 math-units-table nil | |
180 math-decls-cache-tag nil | |
181 math-eval-rules-cache-tag t | |
182 math-graph-var-cache nil | |
183 math-graph-data-cache nil | |
184 math-format-date-cache nil | |
185 math-holidays-cache-tag t) | |
186 (mapcar (function (lambda (x) (set x -100))) math-cache-list) | |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
187 (message "All internal calculator caches have been reset"))) |
40785 | 188 |
189 | |
190 ;;; Conversions. | |
191 | |
192 (defun calc-clean (n) | |
193 (interactive "P") | |
194 (calc-slow-wrapper | |
195 (calc-with-default-simplification | |
196 (let ((func (if (calc-is-hyperbolic) 'calcFunc-clean 'calcFunc-pclean))) | |
197 (calc-enter-result 1 "cln" | |
198 (if n | |
199 (let ((n (prefix-numeric-value n))) | |
200 (list func | |
201 (calc-top-n 1) | |
202 (if (<= n 0) | |
203 (+ n calc-internal-prec) | |
204 n))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
205 (list func (calc-top-n 1)))))))) |
40785 | 206 |
207 (defun calc-clean-num (num) | |
208 (interactive "P") | |
209 (calc-clean (- (if num | |
210 (prefix-numeric-value num) | |
211 (if (and (>= last-command-char ?0) | |
212 (<= last-command-char ?9)) | |
213 (- last-command-char ?0) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
214 (error "Number required")))))) |
40785 | 215 |
216 | |
41271
fcd507927105
Change all toplevel `setq' forms to `defvar' forms, and move them
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
217 (defvar math-chopping-small nil) |
40785 | 218 (defun calcFunc-clean (a &optional prec) ; [X X S] [Public] |
219 (if prec | |
220 (cond ((Math-messy-integerp prec) | |
221 (calcFunc-clean a (math-trunc prec))) | |
222 ((or (not (integerp prec)) | |
223 (< prec 3)) | |
224 (calc-record-why "*Precision must be an integer 3 or above") | |
225 (list 'calcFunc-clean a prec)) | |
226 ((not (Math-objvecp a)) | |
227 (list 'calcFunc-clean a prec)) | |
228 (t (let ((calc-internal-prec prec) | |
229 (math-chopping-small t)) | |
230 (calcFunc-clean (math-normalize a))))) | |
231 (cond ((eq (car-safe a) 'polar) | |
232 (let ((theta (math-mod (nth 2 a) | |
233 (if (eq calc-angle-mode 'rad) | |
234 (math-two-pi) | |
235 360)))) | |
236 (math-neg | |
237 (math-neg | |
238 (math-normalize | |
239 (list 'polar | |
240 (calcFunc-clean (nth 1 a)) | |
241 (calcFunc-clean theta))))))) | |
242 ((memq (car-safe a) '(vec date hms)) | |
243 (cons (car a) (mapcar 'calcFunc-clean (cdr a)))) | |
244 ((memq (car-safe a) '(cplx mod sdev intv)) | |
245 (math-normalize (cons (car a) (mapcar 'calcFunc-clean (cdr a))))) | |
246 ((eq (car-safe a) 'float) | |
247 (if math-chopping-small | |
248 (if (or (> (nth 2 a) (- calc-internal-prec)) | |
249 (Math-lessp (- calc-internal-prec) (calcFunc-xpon a))) | |
250 (if (and (math-num-integerp a) | |
251 (math-lessp (calcFunc-xpon a) calc-internal-prec)) | |
252 (math-trunc a) | |
253 a) | |
254 0) | |
255 a)) | |
256 ((Math-objectp a) a) | |
257 ((math-infinitep a) a) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
258 (t (list 'calcFunc-clean a))))) |
40785 | 259 |
260 (defun calcFunc-pclean (a &optional prec) | |
261 (math-map-over-constants (function (lambda (x) (calcFunc-clean x prec))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
262 a)) |
40785 | 263 |
264 (defun calcFunc-pfloat (a) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
265 (math-map-over-constants 'math-float a)) |
40785 | 266 |
267 (defun calcFunc-pfrac (a &optional tol) | |
268 (math-map-over-constants (function (lambda (x) (calcFunc-frac x tol))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
269 a)) |
40785 | 270 |
271 (defun math-map-over-constants (func expr) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
272 (math-map-over-constants-rec expr)) |
40785 | 273 |
274 (defun math-map-over-constants-rec (expr) | |
275 (cond ((or (Math-primp expr) | |
276 (memq (car expr) '(intv sdev))) | |
277 (or (and (Math-objectp expr) | |
278 (funcall func expr)) | |
279 expr)) | |
280 ((and (memq (car expr) '(^ calcFunc-subscr)) | |
281 (eq func 'math-float) | |
282 (= (length expr) 3) | |
283 (Math-integerp (nth 2 expr))) | |
284 (list (car expr) | |
285 (math-map-over-constants-rec (nth 1 expr)) | |
286 (nth 2 expr))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
287 (t (cons (car expr) (mapcar 'math-map-over-constants-rec (cdr expr)))))) |
40785 | 288 |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
289 ;;; calc-stuff.el ends here |